From b1aad8e7fa9bb9e6993fc338ce10c622b0d264c2 Mon Sep 17 00:00:00 2001 From: Sophist Date: Sat, 5 Mar 2016 21:58:18 +0000 Subject: [PATCH] New Windows-only Class WebAsyncClient This is an alternative way of submitting asynchronous Web calls to WenAsyncWrapper. The WebClientAsync class truly wraps the WebClient class, providing the same methods and properties and passing them through to WebClient. It is inspired by WebAsyncWrapper and tries to make async calls as compatible as possible with WebClient. It also provides an ExecuteAsync method that kicks off a web call (using another WebClientAsyncInstance class) and passes results or errors back to the caller using Events. Like WebAsyncWrapper it relies on WinHttpRequest and so is Windows only (or at least until someone writes a WebHttpRequest compatible class for Mac like Tim has done with the Dictionary class). Because it returns results using Events, it can only be called from another Class module, however it is the authors belief that anyone doing Async calls is likely to be using classes anyway. Having written and undertaken some simple tests, I am submitting this code for early review. Once I have written the real code that will use it and ironed out any bugs found, and rounded out the comments I will let you know it is ready for merging. --- src/WebClientAsync.cls | 385 +++++++++++++++++++++++++++++++++ src/WebClientAsyncInstance.cls | 151 +++++++++++++ 2 files changed, 536 insertions(+) create mode 100644 src/WebClientAsync.cls create mode 100644 src/WebClientAsyncInstance.cls diff --git a/src/WebClientAsync.cls b/src/WebClientAsync.cls new file mode 100644 index 00000000..2bdc0b89 --- /dev/null +++ b/src/WebClientAsync.cls @@ -0,0 +1,385 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "WebClientAsync" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +'' +' WebClientAsync v4.0.21 +' (c) Tim Hall - https://github.com/VBA-tools/VBA-Web +' +' `WebClientAsync` is a an asynchronous wrapper for the WebClient class, +' providing a more intuitive way of running asynchronous requests than using +' WebAsyncWrapper, and delivering results and errors back through VBA Events. +' +' _Note_ Windows-only and requires reference to "Microsoft WinHTTP Services, version 5.1" +' +' Usage: +' +' ```VBA +' Dim WithEvents Client As New WebClientAsync +' Client.BaseUrl = "https://www.example.com/api/" +' +' Dim Auth As New HttpBasicAuthenticator +' Auth.Setup Username, Password +' Set Client.Authenticator = Auth +' +' Dim Request As New WebRequest +' Dim Response As WebResponse +' ' Setup WebRequest... +' +' Client.ExecuteAsync(Request, uniqueArgs) +' ' -> Uses Http Basic authentication and appends Request.Resource to BaseUrl +' +' Private Sub Client_AsyncResponse(Response as WebResponse, uniqueArgs) +' ' Process response here +' End Sub +' +' Private Sub Client_AsyncError(Response as WebResponse, uniqueArgs) +' ' Handle response here +' End Sub +' ``` +' +' Errors: +' 11010 / 80042b02 / -2147210494 - cURL error in Execute +' 11011 / 80042b03 / -2147210493 - Error in Execute +' 11012 / 80042b04 / -2147210492 - Error preparing http request +' 11080 - Active async requests must have unique RequestRef +' 11081 - Unable to find request to abort +' +' @class WebClientAsync +' @author Paul Freeman +' @license MIT (http://www.opensource.org/licenses/mit-license.php) +'' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' + +Option Explicit +' This is a Windows only module - so leave as blank class if Mac +#If Not Mac Then + +' ============================================= ' +' Global Class Declarations +' ============================================= ' + +' --------------------------------------------- ' +' Module constants +' --------------------------------------------- ' +Private Const DefaultMaxAsyncRequests As Integer = 8 + +' --------------------------------------------- ' +' Windows Kernel timing functions +' --------------------------------------------- ' + +#If VBA7 Then + Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long + Private Declare PtrSafe Function getFrequency Lib "kernel32" () As Long +#Else + Private Declare Function GetTickCount Lib "kernel32" () As Long + Private Declare Function getFrequency Lib "kernel32" () As Long +#End If + +' --------------------------------------------- ' +' Public Class Variables +' --------------------------------------------- ' + +'' +' Request that is currently executing. +' +' @property Request +' @type WebRequest +'' +Public Request As WebRequest +Public MaxAsyncRequests As Integer + +' --------------------------------------------- ' +' Events created +' --------------------------------------------- ' + +Event AsyncResponse(ByVal Response As WebResponse, ByVal RequestRef As Variant) +Event AsyncError(ByVal ErrorNumber As Long, ByVal errorDescription As String, ByVal RequestRef As Variant) + +' --------------------------------------------- ' +' Constants and Private Variables +' --------------------------------------------- ' + +Private Client As WebClient +Private ActiveRequests As Collection +Private QueuedRequests As Collection +Private WithEvents WCAI As WebClientAsyncInstance +Attribute WCAI.VB_VarHelpID = -1 +Private newWCAI As WebClientAsyncInstance +' ============================================= ' +' Code +' ============================================= ' +' --------------------------------------------- ' +' Class Initialisation / Termination +' --------------------------------------------- ' +Private Sub Class_Initialize() + WebHelpers.LogDebug "Initializing", "WebClientAsync.Class_Initialize" + + Set ActiveRequests = New Collection + + Set QueuedRequests = New Collection + Set Client = New WebClient + ' WCAI is a Delegate object which is called to raise events + Set WCAI = New WebClientAsyncInstance + ' We create a newWCAI instance in advance in order to + ' avoid delay to instantiate the class before issuing the web request + Set newWCAI = New WebClientAsyncInstance + Set newWCAI.Delegate = WCAI + MaxAsyncRequests = DefaultMaxAsyncRequests +End Sub +Private Sub Class_Terminate() + WebHelpers.LogDebug "Terminating", "WebClientAsync.Class_Terminate" + + Dim instance As WebClientAsyncInstance + For Each instance In ActiveRequests + WebHelpers.LogDebug "Aborting WebClientAsyncInstance: " & instance.nonce, "WebClientAsync.Abort" + instance.Abort "WebClientAsync terminating" + ActiveRequests.Remove instance.nonce + Next instance + Set ActiveRequests = Nothing + Set Client = Nothing +End Sub + +' --------------------------------------------- ' +' Public Methods - Extending WebClient +' --------------------------------------------- ' +Public Sub ExecuteAsync( _ + ByVal Request As WebRequest, _ + Optional ByVal RequestRef As Variant, _ + Optional ByVal Priority As Boolean _ + ) + WebHelpers.LogDebug "Called", "WebClientAsync.ExecuteAsync" + + Dim errMsg As String + Dim nonce As String + Dim instance As WebClientAsyncInstance + + ' RequestRef must be unique + For Each instance In ActiveRequests + If RequestRef = instance.RequestRef Then GoTo DuplicateReqArgs + Next instance + For Each instance In QueuedRequests + If RequestRef = instance.RequestRef Then GoTo DuplicateReqArgs + Next instance + + nonce = WebHelpers.CreateNonce + newWCAI.nonce = nonce + Set newWCAI.Request = Request.Clone + Set newWCAI.Client = Client + If IsObject(RequestRef) Then + Set newWCAI.RequestRef = RequestRef + Else + newWCAI.RequestRef = RequestRef + End If + If Priority Then + QueuedRequests.Add Item:=newWCAI, Key:=nonce, Before:=1 + Else + QueuedRequests.Add Item:=newWCAI, Key:=nonce + End If + Call ExecuteQueuedRequests + Set newWCAI = New WebClientAsyncInstance + Set newWCAI.Delegate = WCAI + Exit Sub + +DuplicateReqArgs: + Dim errorDescription As String + + errorDescription = "Active async requests must have unique RequestRef" + WebHelpers.LogError errorDescription, "WebClientAsync.ExecuteAsync", 11080 + Err.Raise 11080 + vbObjectError, "WebClientAsync.ExecuteAsync", errorDescription + +End Sub +Public Sub Abort(Optional ByVal Reason As String = "", Optional ByVal RequestRef As Variant) + WebHelpers.LogDebug "Called", "WebClientAsync.Abort" + + Dim instance As WebClientAsyncInstance + For Each instance In ActiveRequests + If instance.RequestRef = RequestRef Then + WebHelpers.LogWarning "Aborting active request: " & instance.nonce, "WebClientAsync.Abort" + instance.Abort Reason + ActiveRequests.Remove instance.nonce + Exit Sub + End If + Next instance + For Each instance In QueuedRequests + If instance.RequestRef = RequestRef Then + WebHelpers.LogWarning "Cancelling queued request: " & instance.nonce, "WebClientAsync.Abort" + QueuedRequests.Remove instance.nonce + Exit Sub + End If + Next instance + + Dim errorDescription As String + errorDescription = "Unable to find request to abort" + WebHelpers.LogError errorDescription, "WebClientAsync.Abort", 11081 + Err.Raise 11081 + vbObjectError, "WebClientAsync.ExecuteAsync", errorDescription + +End Sub + +Public Function Exists(Optional ByVal RequestRef As Variant) As Boolean + For Each instance In ActiveRequests + If instance.RequestRef = RequestRef Then + Exists = True + Exit Function + End If + Next instance + For Each instance In QueuedRequests + If instance.RequestRef = RequestRef Then + Exists = True + Exit Function + End If + Next instance + Exists = False +End Function + +' --------------------------------------------- ' +' Event Handlers +' --------------------------------------------- ' +Private Sub WCAI_AsyncError(ByVal nonce As String, ByVal ErrorNumber As Long, ByVal errorDescription As String, ByVal RequestRef As Variant) + WebHelpers.LogDebug "Called", "WebClientAsync.AsyncError" + ActiveRequests.Remove nonce + RaiseEvent AsyncError(ErrorNumber, errorDescription, RequestRef) + Call ExecuteQueuedRequests +End Sub + +Private Sub WCAI_AsyncResponse(ByVal nonce As String, ByVal Response As WebResponse, ByVal RequestRef As Variant) + WebHelpers.LogDebug "Called", "WebClientAsync.AsyncResponse" + ActiveRequests.Remove nonce + RaiseEvent AsyncResponse(Response, RequestRef) +End Sub + +' --------------------------------------------- ' +' Private Subs and Functions +' --------------------------------------------- ' +Private Sub ExecuteQueuedRequests() + Dim instance As WebClientAsyncInstance + Do While ActiveRequests.Count < MaxAsyncRequests And QueuedRequests.Count > 0 + Set instance = QueuedRequests(1) + QueuedRequests.Remove instance.nonce + ActiveRequests.Add Item:=instance, Key:=instance.nonce + + On Error GoTo RequestError + newWCAI.ExecuteAsyncInstance + On Error GoTo 0 + Loop + Exit Sub + +RequestError: + WebHelpers.LogError "WebClientAsyncInstance error " & Err.Number & ": " & Err.Description, "WebClientAsync.ExecuteAsync" + ActiveRequests.Remove instance.nonce + ' Rethrow error + Err.Raise Err.Number, Err.source, Err.Description +End Sub + +' --------------------------------------------- ' +' Public Properties - Passthrough to WebClient +' --------------------------------------------- ' + +Public Property Get BaseUrl() As String + BaseUrl = Client.BaseUrl +End Property +Public Property Let BaseUrl(Value As String) + Client.BaseUrl = Value +End Property + +Public Property Get Authenticator() As IWebAuthenticator + Set Authenticator = Client.Authenticator +End Property +Public Property Set Authenticator(Value As IWebAuthenticator) + Set Client.Authenticator = Value +End Property + +Public Property Get TimeoutMs() As Long + TimeoutMs = Client.TimeoutMs +End Property +Public Property Let TimeoutMs(Value As Long) + Client.TimeoutMs = Value +End Property + +Public Property Get ProxyServer() As String + ProxyServer = Client.ProxyServer +End Property +Public Property Let ProxyServer(Value As String) + Client.ProxyServer = Value +End Property + +Public Property Get ProxyBypassList() As String + ProxyBypassList = Client.ProxyBypassList +End Property +Public Property Let ProxyBypassList(Value As String) + Client.ProxyBypassList = Value +End Property + +Public Property Get ProxyUsername() As String + ProxyUsername = Client.ProxyUsername +End Property +Public Property Let ProxyUsername(Value As String) + Client.ProxyUsername = Value +End Property + +Public Property Get ProxyPassword() As String + ProxyPassword = Client.ProxyPassword +End Property +Public Property Let ProxyPassword(Value As String) + Client.ProxyPassword = Value +End Property + +Public Property Get EnableAutoProxy() As Boolean + EnableAutoProxy = Client.EnableAutoProxy +End Property +Public Property Let EnableAutoProxy(Value As Boolean) + Client.EnableAutoProxy = Value +End Property + +Public Property Get Insecure() As Boolean + Insecure = Client.Insecure +End Property +Public Property Let Insecure(Value As Boolean) + Client.Insecure = Value +End Property + +Public Property Get FollowRedirects() As Boolean + FollowRedirects = Client.FollowRedirects +End Property +Public Property Let FollowRedirects(Value As Boolean) + Client.FollowRedirects = Value +End Property + +' --------------------------------------------- ' +' Public Methods - Passthrough to WebClient +' --------------------------------------------- ' + +Public Function Execute(Request As WebRequest) As WebResponse + ' Although this is intended as an async client, + ' the sync execution functions are mapped in order to + ' allow the user to choose sync/async at run time. + WebHelpers.LogDebug "WebAsyncRequest.Execute called", "WebClientAsync.Execute" + Execute = Client.Execute(Request) +End Function + +Public Function GetJson(Url As String, Optional Options As Dictionary = Nothing) As WebResponse + GetJson = Client.GetJson(Url, Options) +End Function + +Public Function PostJson(Url As String, Body As Variant, Optional Options As Dictionary = Nothing) As WebResponse + PostJson = Client.PostJson(Url, Body, Options) +End Function + +Public Function GetFullUrl(Request As WebRequest) As String + GetFullUrl = Client.GetFullUrl(Request) +End Function + +Public Sub SetProxy( _ + Server As String, _ + Optional Username As String = "", _ + Optional Password As String = "", _ + Optional BypassList As String = "") + Client.SetProxy Server, Username, Password, BypassList +End Sub + +#End If + diff --git a/src/WebClientAsyncInstance.cls b/src/WebClientAsyncInstance.cls new file mode 100644 index 00000000..a999fced --- /dev/null +++ b/src/WebClientAsyncInstance.cls @@ -0,0 +1,151 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "WebClientAsyncInstance" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +'' +' WebClientAsyncInstance v4.0.21 +' (c) Tim Hall - https://github.com/VBA-tools/VBA-Web +' +' `WebClientAsyncInstance` is an INTERNAL helper class for WebClientAsync. +' A helper class is required to allow the same WebClientAsync instance +' to be used for multiple simultaneous web calls. In essence, the HTTP +' request sends results back through an event. The only way to identify +' the specific call that produced the response is to have the HTTP instance +' associated with a unique event processor i.e. a unique object instance. +' +' _Note_ Windows-only and requires reference to "Microsoft WinHTTP Services, version 5.1" +' +' @class WebClientAsyncInstance +' @author Paul Freeman +' @license MIT (http://www.opensource.org/licenses/mit-license.php) +'' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' + +Option Explicit +#If Not Mac Then + +' --------------------------------------------- ' +' Events created +' --------------------------------------------- ' + +Event AsyncResponse(ByVal nonce As String, ByVal Response As WebResponse, ByVal RequestRef As Variant) +Event AsyncError(ByVal nonce As String, ByVal ErrorNumber As Long, ByVal errorDescription As String, ByVal RequestRef As Variant) + +' --------------------------------------------- ' +' Constants and Private Variables +' --------------------------------------------- ' +Private RequestStartTicks As Long +Private TimerTickFrequency As Currency + +' --------------------------------------------- ' +' Public Variables +' --------------------------------------------- ' + +Public nonce As String +Public Request As WebRequest +Public Client As WebClient +Public WithEvents Http As WinHttpRequest +Attribute Http.VB_VarHelpID = -1 +Public RequestRef As Variant + +'' +' Delegate instance use to pass Events back. +' +' @property Delegate +' @type WebClientAsyncInstance +'' +Public Delegate As WebClientAsyncInstance + +' --------------------------------------------- ' +' Windows Kernel timing functions +' --------------------------------------------- ' + +#If VBA7 Then + Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long + Private Declare PtrSafe Function getFrequency Lib "kernel32" _ + Alias "QueryPerformanceFrequency" (cyFrequency As Currency) As Long +#Else + Private Declare Function GetTickCount Lib "kernel32" () As Long + Private Declare Function getFrequency Lib "kernel32" _ + Alias "QueryPerformanceFrequency" (cyFrequency As Currency) As Long +#End If + +Public Sub ExecuteAsyncInstance() + WebHelpers.LogDebug "Called", "WebClientAsyncInstance.ExecuteAsyncInstance" + Set Me.Http = Client.PrepareHttpRequest(Me.Request) + + Me.Http.Send Request.Body + RequestStartTicks = GetTickCount() + WebHelpers.LogDebug "Ended", "WebAsyncRequestInstance.ExecuteAsyncInstance" +End Sub +Public Sub Abort(Optional Reason As String = "") + WebHelpers.LogDebug "Called", "WebAsyncRequestInstance.Abort" + If Reason <> "" Then Reason = ": " & Reason + If Not Me.Http Is Nothing Then + Me.Http.Abort + WebHelpers.LogDebug "Aborted" & Reason, "WebClientAsyncInstance.Abort" + Else + WebHelpers.LogDebug "Not running" & Reason, "WebClientAsyncInstance.Abort" + End If + + Set Me.Request = Nothing + Set Me.Http = Nothing + WebHelpers.LogDebug "Ended", "WebAsyncRequestInstance.Abort" +End Sub +Public Sub Http_OnError(ByVal ErrNo As Long, ByVal ErrDesc As String) + WebHelpers.LogError "WinHttpRequest error" & ErrNo & ": " & ErrDesc, "WebClientAsyncInstance.Http_OnError" + Delegate.Delegate_AsyncError Me.nonce, ErrNo, ErrDesc, Me.RequestRef +End Sub +Public Sub Delegate_AsyncError(ByVal nonce As String, ByVal ErrNo As Long, ByVal ErrDesc As String, RequestRef As Variant) + RaiseEvent AsyncError(nonce, ErrNo, ErrDesc, RequestRef) +End Sub +Public Sub Http_OnResponseStart(ByVal Status As Long, ByVal ContentType As String) + WebHelpers.LogDebug "WinHttpRequest response starting: " & ElapsedTimeMs() & "ms", "WebClientAsyncInstance.Http_OnResponseStart" +End Sub +Private Sub Http_OnResponseDataAvailable(Data() As Byte) + WebHelpers.LogDebug "WinHttpRequest response data available: " & ElapsedTimeMs() & "ms", "WebClientAsyncInstance.Http_OnResponseDataAvailable" +End Sub +Private Sub Http_OnResponseFinished() + WebHelpers.LogDebug "WinHttpRequest response finished: " & ElapsedTimeMs() & "ms", "WebClientAsyncInstance.Http_OnResponseFinish" + + Dim web_Response As New WebResponse + + web_Response.CreateFromHttp Me.Client, Me.Request, Me.Http + WebHelpers.LogResponse Me.Client, Me.Request, web_Response + + Set Me.Request = Nothing + Set Me.Http = Nothing + WebHelpers.LogDebug "Raising AsyncResponse Event: " & Me.nonce, "WebClientAsyncInstance.OnResponseFinish" + Delegate.Delegate_AsyncResponse Me.nonce, web_Response, Me.RequestRef +End Sub +Public Sub Delegate_AsyncResponse(ByVal nonce As String, web_Response As WebResponse, RequestRef As Variant) + RaiseEvent AsyncResponse(nonce, web_Response, RequestRef) +End Sub +Private Function ElapsedTimeMs() As Long + ' Test whether you are using the 64-bit version of Office 2010. + Dim e As Long + + ElapsedTimeMs = 0 + e = GetTickCount() + If RequestStartTicks = 0 Then + RequestStartTicks = e + Else + e = e - RequestStartTicks + If e < 0 Then e = CLng(CCur(e) + 4294967296#) + If TimerTickFrequency = 0 Then getFrequency TimerTickFrequency + If TimerTickFrequency <> 0 Then ElapsedTimeMs = e / TimerTickFrequency + End If +End Function +Private Sub Class_Terminate() + WebHelpers.LogDebug "Terminating", "WebClientAsyncInstance.terminate" + Set Me.Request = Nothing + Set Me.Client = Nothing + Set Me.Http = Nothing +End Sub + +#End If +