1' The MIT License (MIT)
2'
3' Copyright (c) 2016 Tim Hall
4'
5' Permission is hereby granted, free of charge, to any person obtaining a copy
6' of this software and associated documentation files (the "Software"), to deal
7' in the Software without restriction, including without limitation the rights
8' to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
9' copies of the Software, and to permit persons to whom the Software is
10' furnished to do so, subject to the following conditions:
11'
12' The above copyright notice and this permission notice shall be included in all
13' copies or substantial portions of the Software.
14'
15' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
17' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
18' AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
19' LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
20' OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
21' SOFTWARE.
22
23VERSION 1.0 CLASS
24BEGIN
25 MultiUse = -1 'True
26END
27Attribute VB_Name = "WebResponse"
28Attribute VB_GlobalNameSpace = False
29Attribute VB_Creatable = False
30Attribute VB_PredeclaredId = False
31Attribute VB_Exposed = True
32''
33' WebResponse v4.1.3
34' (c) Tim Hall - https://github.com/VBA-tools/VBA-Web
35'
36' Wrapper for http/cURL responses that includes parsed Data based on WebRequest.ResponseFormat.
37'
38' Usage:
39' ```VB.net
40' Dim Response As WebResponse
41' Set Response = Client.Execute(Request)
42'
43' If Response.StatusCode = WebStatusCode.Ok Then
44' ' Response.Headers, Response.Cookies
45' ' Response.Data -> Parsed Response.Content based on Request.ResponseFormat
46' ' Response.Body -> Raw response bytes
47' Else
48' Debug.Print "Error: " & Response.StatusCode & " - " & Response.Content
49' End If
50' ```
51'
52' Errors:
53' 11030 / 80042b16 / -2147210474 - Error creating from http
54' 11031 / 80042b17 / -2147210473 - Error creating from cURL
55' 11032 / 80042b18 / -2147210472 - Error extracting headers
56'
57' @class WebResponse
58' @author tim.hall.engr@gmail.com
59' @license MIT (http://www.opensource.org/licenses/mit-license.php)
60'' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ '
61Option Explicit
62
63Private web_CrLf As String
64
65' --------------------------------------------- '
66' Properties
67' --------------------------------------------- '
68
69''
70' Status code that the server returned (e.g. 200).
71'
72' @property StatusCode
73' @type WebStatusCode
74''
75Public StatusCode As WebStatusCode
76
77''
78' Status string that the server returned (e.g. `404 -> "Not Found"`)
79'
80' @property StatusDescription
81' @type String
82''
83Public StatusDescription As String
84
85''
86' Content string that the server returned.
87'
88' @property Content
89' @type String
90''
91Public Content As String
92
93''
94' Raw bytes for the response.
95'
96' @property Body
97' @type Byte()
98''
99Public Body As Variant
100
101''
102' Parsed `Content` or `Body` based on the `WebRequest.ResponseFormat`.
103'
104' @property Data
105' @type Dictionary|Collection
106''
107Public Data As Object
108
109''
110' Headers that were included with the response.
111' (`Collection` of `KeyValue`)
112'
113' @property Headers
114' @type Collection
115''
116Public Headers As Collection
117
118''
119' Cookies that were included with the response.
120' (`Collection` of `KeyValue`)
121'
122' @property Cookies
123' @type Collection
124''
125Public Cookies As Collection
126
127' ============================================= '
128' Public Methods
129' ============================================= '
130
131''
132' Helper for updating the response with the given updated response values.
133' Useful for `ByRef` cases to update response in place.
134'
135' @method Update
136' @param Updated {WebResponse} Updated `WebResponse` to pull updated values from
137''
138Public Sub Update(Updated As WebResponse)
139 Me.StatusCode = Updated.StatusCode
140 Me.StatusDescription = Updated.StatusDescription
141 Me.Content = Updated.Content
142 Me.Body = Updated.Body
143 Set Me.Headers = Updated.Headers
144 Set Me.Cookies = Updated.Cookies
145 Set Me.Data = Updated.Data
146End Sub
147
148''
149' Create response from http
150'
151' @internal
152' @method CreateFromHttp
153' @param {WebClient} Client
154' @param {WebRequest} Request
155' @param {WinHttpRequest} Http
156' @throws 11030 / 80042b16 / -2147210474 - Error creating from http
157''
158Public Sub CreateFromHttp(Client As WebClient, Request As WebRequest, Http As Object)
159 On Error GoTo web_ErrorHandling
160
161 Me.StatusCode = Http.Status
162 Me.StatusDescription = Http.StatusText
163 Me.Content = Http.ResponseText
164 Me.Body = Http.ResponseBody
165
166 web_LoadValues Http.GetAllResponseHeaders, Me.Content, Me.Body, Request
167
168 Exit Sub
169
170web_ErrorHandling:
171
172 Dim web_ErrorDescription As String
173 web_ErrorDescription = "An error occurred while creating response from http" & vbNewLine & _
174 Err.Number & VBA.IIf(Err.Number < 0, " (" & VBA.LCase$(VBA.Hex$(Err.Number)) & ")", "") & ": " & Err.Description
175
176 WebHelpers.LogError web_ErrorDescription, "WebResponse.CreateFromHttp", 11030 + vbObjectError
177 Err.Raise 11030 + vbObjectError, "WebResponse.CreateFromHttp", web_ErrorDescription
178End Sub
179
180''
181' Create response from cURL
182'
183' @internal
184' @method CreateFromCurl
185' @param {WebClient} Client
186' @param {WebRequest} Request
187' @param {String} Result
188' @throws 11031 / 80042b17 / -2147210473 - Error creating from cURL
189''
190Public Sub CreateFromCurl(Client As WebClient, Request As WebRequest, Result As String)
191 On Error GoTo web_ErrorHandling
192
193 Dim web_Lines() As String
194
195 web_Lines = VBA.Split(Result, web_CrLf)
196
197 Me.StatusCode = web_ExtractStatusFromCurlResponse(web_Lines)
198 Me.StatusDescription = web_ExtractStatusTextFromCurlResponse(web_Lines)
199 Me.Content = web_ExtractResponseTextFromCurlResponse(web_Lines)
200 Me.Body = WebHelpers.StringToAnsiBytes(Me.Content)
201
202 web_LoadValues web_ExtractHeadersFromCurlResponse(web_Lines), Me.Content, Me.Body, Request
203
204 Exit Sub
205
206web_ErrorHandling:
207
208 Dim web_ErrorDescription As String
209 web_ErrorDescription = "An error occurred while creating response from cURL" & vbNewLine & _
210 Err.Number & VBA.IIf(Err.Number < 0, " (" & VBA.LCase$(VBA.Hex$(Err.Number)) & ")", "") & ": " & Err.Description
211
212 WebHelpers.LogError web_ErrorDescription, "WebResponse.CreateFromCurl", 11031 + vbObjectError
213 Err.Raise 11031 + vbObjectError, "WebResponse.CreateFromCurl", web_ErrorDescription
214End Sub
215
216''
217' Extract headers from response headers
218'
219' @internal
220' @method ExtractHeaders
221' @param {String} ResponseHeaders
222' @return {Collection} Headers
223' @throws 11032 / 80042b18 / -2147210472 - Error extracting headers
224''
225Public Function ExtractHeaders(ResponseHeaders As String) As Collection
226 On Error GoTo web_ErrorHandling
227
228 Dim web_Lines As Variant
229 Dim web_i As Integer
230 Dim web_Headers As New Collection
231 Dim web_Header As Dictionary
232 Dim web_ColonPosition As Long
233 Dim web_Multiline As Boolean
234
235 web_Lines = VBA.Split(ResponseHeaders, web_CrLf)
236
237 For web_i = LBound(web_Lines) To (UBound(web_Lines) + 1)
238 If web_i > UBound(web_Lines) Then
239 web_Headers.Add web_Header
240 ElseIf web_Lines(web_i) <> "" Then
241 web_ColonPosition = VBA.InStr(1, web_Lines(web_i), ":")
242 If web_ColonPosition = 0 And Not web_Header Is Nothing Then
243 ' Assume part of multi-line header
244 web_Multiline = True
245 ElseIf web_Multiline Then
246 ' Close out multi-line string
247 web_Multiline = False
248 web_Headers.Add web_Header
249 ElseIf Not web_Header Is Nothing Then
250 ' Add previous header
251 web_Headers.Add web_Header
252 End If
253
254 If Not web_Multiline Then
255 Set web_Header = WebHelpers.CreateKeyValue( _
256 Key:=VBA.Trim(VBA.Mid$(web_Lines(web_i), 1, web_ColonPosition - 1)), _
257 Value:=VBA.Trim(VBA.Mid$(web_Lines(web_i), web_ColonPosition + 1, VBA.Len(web_Lines(web_i)))) _
258 )
259 Else
260 web_Header("Value") = web_Header("Value") & web_CrLf & web_Lines(web_i)
261 End If
262 End If
263 Next web_i
264
265 Set ExtractHeaders = web_Headers
266 Exit Function
267
268web_ErrorHandling:
269
270 Dim web_ErrorDescription As String
271 web_ErrorDescription = "An error occurred while extracting headers" & vbNewLine & _
272 Err.Number & VBA.IIf(Err.Number < 0, " (" & VBA.LCase$(VBA.Hex$(Err.Number)) & ")", "") & ": " & Err.Description
273
274 WebHelpers.LogError web_ErrorDescription, "WebResponse.CreateFromCurl", 11032 + vbObjectError
275 Err.Raise 11032 + vbObjectError, "WebResponse.CreateFromCurl", web_ErrorDescription
276End Function
277
278''
279' Extract cookies from response headers
280'
281' @internal
282' @method ExtractCookies
283' @param {Collection} Headers
284' @return {Collection} Cookies
285''
286Public Function ExtractCookies(Headers As Collection) As Collection
287 Dim web_Header As Dictionary
288 Dim web_Cookie As String
289 Dim web_Key As String
290 Dim web_Value As String
291 Dim web_Cookies As New Collection
292
293 For Each web_Header In Headers
294 If web_Header("Key") = "Set-Cookie" Then
295 web_Cookie = web_Header("Value")
296 If VBA.InStr(1, web_Cookie, "=") > 0 Then
297 web_Key = VBA.Mid$(web_Cookie, 1, VBA.InStr(1, web_Cookie, "=") - 1)
298 web_Value = VBA.Mid$(web_Cookie, VBA.InStr(1, web_Cookie, "=") + 1, VBA.Len(web_Cookie))
299
300 ' Ignore text after semi-colon
301 If VBA.InStr(1, web_Value, ";") > 0 Then
302 web_Value = VBA.Mid$(web_Value, 1, VBA.InStr(1, web_Value, ";") - 1)
303 End If
304
305 ' Ignore surrounding quotes
306 If VBA.Left$(web_Value, 1) = """" Then
307 web_Value = VBA.Mid$(web_Value, 2, VBA.Len(web_Value) - 2)
308 End If
309
310 web_Cookies.Add WebHelpers.CreateKeyValue(web_Key, WebHelpers.UrlDecode(web_Value, PlusAsSpace:=False, EncodingMode:=UrlEncodingMode.CookieUrlEncoding))
311 Else
312 WebHelpers.LogWarning _
313 "Unrecognized cookie format: " & web_Cookie, "WebResponse.ExtractCookies"
314 End If
315 End If
316 Next web_Header
317
318 Set ExtractCookies = web_Cookies
319End Function
320
321' ============================================= '
322' Private Functions
323' ============================================= '
324
325Private Sub web_LoadValues(web_Headers As String, web_Content As String, web_Body As Variant, web_Request As WebRequest)
326 ' Convert content to data by format
327 If web_Request.ResponseFormat <> WebFormat.PlainText Then
328 On Error Resume Next
329 Set Me.Data = _
330 WebHelpers.ParseByFormat(web_Content, web_Request.ResponseFormat, web_Request.CustomResponseFormat, web_Body)
331
332 If Err.Number <> 0 Then
333 WebHelpers.LogError Err.Description, Err.Source, Err.Number
334 Err.Clear
335 End If
336 On Error GoTo 0
337 End If
338
339 ' Extract headers
340 Set Me.Headers = ExtractHeaders(web_Headers)
341
342 ' Extract cookies
343 Set Me.Cookies = ExtractCookies(Me.Headers)
344End Sub
345
346Private Function web_ExtractStatusFromCurlResponse(web_CurlResponseLines() As String) As Long
347 Dim web_StatusLineParts() As String
348
349 web_StatusLineParts = VBA.Split(web_CurlResponseLines(web_FindStatusLine(web_CurlResponseLines)), " ")
350 web_ExtractStatusFromCurlResponse = VBA.CLng(web_StatusLineParts(1))
351End Function
352
353Private Function web_ExtractStatusTextFromCurlResponse(web_CurlResponseLines() As String) As String
354 Dim web_StatusLineParts() As String
355 Dim web_i As Long
356 Dim web_StatusText As String
357
358 web_StatusLineParts = VBA.Split(web_CurlResponseLines(web_FindStatusLine(web_CurlResponseLines)), " ", 3)
359 web_ExtractStatusTextFromCurlResponse = web_StatusLineParts(2)
360End Function
361
362Private Function web_ExtractHeadersFromCurlResponse(web_CurlResponseLines() As String) As String
363 Dim web_StatusLineIndex As Long
364 Dim web_BlankLineIndex As Long
365 Dim web_HeaderLines() As String
366 Dim web_WriteIndex As Long
367 Dim web_ReadIndex As Long
368
369 ' Find status line and blank line before body
370 web_StatusLineIndex = web_FindStatusLine(web_CurlResponseLines)
371 web_BlankLineIndex = web_FindBlankLine(web_CurlResponseLines)
372
373 ' Extract headers string
374 ReDim web_HeaderLines(0 To web_BlankLineIndex - 2 - web_StatusLineIndex)
375
376 web_WriteIndex = 0
377 For web_ReadIndex = (web_StatusLineIndex + 1) To web_BlankLineIndex - 1
378 web_HeaderLines(web_WriteIndex) = web_CurlResponseLines(web_ReadIndex)
379 web_WriteIndex = web_WriteIndex + 1
380 Next web_ReadIndex
381
382 web_ExtractHeadersFromCurlResponse = VBA.Join$(web_HeaderLines, web_CrLf)
383End Function
384
385Private Function web_ExtractResponseTextFromCurlResponse(web_CurlResponseLines() As String) As String
386 Dim web_BlankLineIndex As Long
387 Dim web_BodyLines() As String
388 Dim web_WriteIndex As Long
389 Dim web_ReadIndex As Long
390
391 ' Find blank line before body
392 web_BlankLineIndex = web_FindBlankLine(web_CurlResponseLines)
393
394 ' Extract body string
395 ReDim web_BodyLines(0 To UBound(web_CurlResponseLines) - web_BlankLineIndex - 1)
396
397 web_WriteIndex = 0
398 For web_ReadIndex = web_BlankLineIndex + 1 To UBound(web_CurlResponseLines)
399 web_BodyLines(web_WriteIndex) = web_CurlResponseLines(web_ReadIndex)
400 web_WriteIndex = web_WriteIndex + 1
401 Next web_ReadIndex
402
403 web_ExtractResponseTextFromCurlResponse = VBA.Join$(web_BodyLines, web_CrLf)
404End Function
405
406Private Function web_FindStatusLine(web_CurlResponseLines() As String) As Long
407 ' Special case for cURL: 100 Continue is included before final status code
408 ' -> ignore 100 and find final status code (next non-100 status code)
409 For web_FindStatusLine = LBound(web_CurlResponseLines) To UBound(web_CurlResponseLines)
410 If VBA.Trim$(web_CurlResponseLines(web_FindStatusLine)) <> "" Then
411 If VBA.Split(web_CurlResponseLines(web_FindStatusLine), " ")(1) <> "100" Then
412 Exit Function
413 End If
414 End If
415 Next web_FindStatusLine
416End Function
417
418Private Function web_FindBlankLine(web_CurlResponseLines() As String) As Long
419 For web_FindBlankLine = (web_FindStatusLine(web_CurlResponseLines) + 1) To UBound(web_CurlResponseLines)
420 If VBA.Trim$(web_CurlResponseLines(web_FindBlankLine)) = "" Then
421 Exit Function
422 End If
423 Next web_FindBlankLine
424End Function
425
426Private Sub Class_Initialize()
427 web_CrLf = VBA.Chr$(&HA) & VBA.Chr$(&o12)
428
429 Set Headers = New Collection
430 Set Cookies = New Collection
431End Sub
432
433Private Sub Test_strings()
434 Dim foo1() As String
435 Set foo1 = " testing
436 1-2-3"
437End Sub
438