diff --git a/src/Inflate.bas b/src/Inflate.bas new file mode 100644 index 00000000..0206a0b0 --- /dev/null +++ b/src/Inflate.bas @@ -0,0 +1,379 @@ +Attribute VB_Name = "Inflate" +Option Explicit + +' GZIP encoding library +' Source: https://stackoverflow.com/questions/58026702/how-to-decompress-http-responses-in-vba-excel + +Private Type CodesType + Lenght As Integer + Code As Long +End Type + +Private OutStream() As Byte +Private OutPos As Long +Private InStream() As Byte +Private crc(3) As Byte +Private size(3) As Byte +Private compressionid() As Byte +Private decompressedsize As Long + + + +Private Inpos As Long +Private ByteBuff As Long +Private BitNum As Integer +Private BitMask(16) As Long +Private BitVal(16) As Long +Private LC(31) As CodesType +Private DC(31) As CodesType +Private LitLen() As CodesType 'Literal/length tree +Private Dist() As CodesType 'Distance tree +Private LenOrder(18) As Integer +Private MinLLenght As Integer 'Minimum length used in literal/lenght codes +Private MaxLLenght As Integer 'Maximum length used in literal/lenght codes +Private MinDLenght As Integer 'Minimum length used in distance codes +Private MaxDLenght As Integer 'Maximum length used in distance codes + + +Private Function checkgzip(Optional ByRef errarray As Variant) As Long + + + If (InStream(0) = 31 And InStream(1) = 139) Then 'Found gzip header + If InStream(2) = 8 Then 'Found Deflate compression method ID + If InStream(3) = 0 Then 'No extra flags are set Refer http://www.onicos.com/staff/iz/formats/gzip.html and https://tools.ietf.org/html/rfc1952#section-2.3 to deal with extra flags + ReDim tmparray(UBound(InStream) - 18) As Byte + Dim counter As Long + For counter = 10 To UBound(InStream) - 8 + tmparray(counter - 10) = InStream(counter) + Next counter + For counter = 0 To 3 + crc(counter) = InStream(UBound(InStream) - 7 + counter) + size(counter) = InStream(UBound(InStream) - 3 + counter) + + Next counter + decompressedsize = Application.WorksheetFunction.Bitlshift(size(3), 24) + _ + Application.WorksheetFunction.Bitlshift(size(2), 16) + _ + Application.WorksheetFunction.Bitlshift(size(1), 8) + _ + size(0) + InStream = tmparray + Else + 'Error extra flags set + ReDim Preserve errarray(UBound(errarray) + 1) + errarray(UBound(errarray)) = "Gzip Error: Extra flags not supported yet!" + checkgzip = -1 + Exit Function + End If + Else + 'Error Didnt find deflate compression id + ReDim Preserve errarray(UBound(errarray) + 1) + errarray(UBound(errarray)) = "Gzip Error: Method other than DEFLATE not supported yet!" + checkgzip = -1 + Exit Function + End If + Else + 'not gzip stream must be just deflate + End If + + + + + + +End Function + + +Public Function Inflate(ByRef ByteArray() As Byte, Optional UncompressedSize As Long = 1000, Optional ZIP64 As Boolean = False, Optional ByRef errarray As Variant) As Long + Dim IsLastBlock As Boolean + Dim CompType As Integer + Dim DoInflate As Boolean + Dim Char As Long + Dim NuBits As Integer + Dim L1 As Long + Dim L2 As Long + Dim X As Long +'Copy local array to global array + InStream = ByteArray + If checkgzip(errarray) = -1 Then + Inflate = -1 + Exit Function + End If + + + +' Erase ByteArray 'clear memory +'Init global variables + Call Init_Inflate(UncompressedSize) + Do + IsLastBlock = (GetBits(1) = 1) + CompType = GetBits(2) + Select Case CompType + Case 0 'file is stored + 'input position is already set 1 position further so whe need to line up next byte + BitNum = 0 + ByteBuff = 0 + L1 = InStream(Inpos) + CLng(InStream(Inpos + 1)) * 256 + Inpos = Inpos + 2 + L2 = InStream(Inpos) + CLng(InStream(Inpos + 1)) * 256 + Inpos = Inpos + 2 + If L1 - (Not (L2) And &HFFFF&) Then Inflate = -2 + For X = 1 To L1 + Call PutByte(InStream(Inpos)) + Inpos = Inpos + 1 + Next + DoInflate = False + Case 1 + Call Create_Static_Tree + DoInflate = True + Case 2 + Call Create_Dynamic_Tree + DoInflate = True + Case 3 + Inflate = -1 + DoInflate = False + End Select + If DoInflate Then + Do + 'read minimum number of bits to speed things up + Char = Bit_Reverse(GetBits(MinLLenght), MinLLenght) + NuBits = MinLLenght + Do While LitLen(Char).Lenght <> NuBits + Char = Char + Char + GetBits(1) + NuBits = NuBits + 1 + Loop + Char = LitLen(Char).Code + If Char < 256 Then + Call PutByte(CByte(Char)) + ElseIf Char > 256 Then + Char = Char - 257 + L1 = LC(Char).Code + GetBits(LC(Char).Lenght) + If L1 = 258 And ZIP64 Then L1 = GetBits(16) + 3 + Char = Bit_Reverse(GetBits(MinDLenght), MinDLenght) + NuBits = MinDLenght + Do While Dist(Char).Lenght <> NuBits + Char = Char + Char + GetBits(1) + NuBits = NuBits + 1 + Loop + Char = Dist(Char).Code + L2 = DC(Char).Code + GetBits(DC(Char).Lenght) + For X = 1 To L1 + Char = OutStream(OutPos - L2) + Call PutByte(CByte(Char)) + Next + End If + Loop While Char <> 256 + End If + Loop While Not IsLastBlock + ReDim Preserve OutStream(OutPos - 1) +'Clear memory + Erase InStream + Erase BitMask + Erase BitVal + Erase LC + Erase DC + Erase LitLen + Erase Dist + Erase LenOrder + ByteArray = OutStream + If UBound(ByteArray) + 1 <> decompressedsize Then 'Decompression length error + ReDim Preserve errarray(UBound(errarray) + 1) + errarray(UBound(errarray)) = "Deflate error: Decompressed size did not match size given in footer!" + Inflate = 1 + End If + + + +End Function + +Private Function Create_Static_Tree() + Dim X As Long + Dim Lenght(287) As Long + For X = 0 To 143: Lenght(X) = 8: Next + For X = 144 To 255: Lenght(X) = 9: Next + For X = 256 To 279: Lenght(X) = 7: Next + For X = 280 To 287: Lenght(X) = 8: Next + If Create_Codes(LitLen, Lenght, 287, MaxLLenght, MinLLenght) <> 0 Then + Create_Static_Tree = -1 + Exit Function + End If + For X = 0 To 31: Lenght(X) = 5: Next + Create_Static_Tree = Create_Codes(Dist, Lenght, 31, MaxDLenght, MinDLenght) +End Function + +Private Function Create_Dynamic_Tree() As Integer + Dim Lenght() As Long + Dim Bl_Tree() As CodesType + Dim MinBL As Integer + Dim MaxBL As Integer + Dim NumLen As Long + Dim Numdis As Long + Dim NumCod As Long + Dim Char As Integer + Dim NuBits As Long + Dim LN As Integer + Dim pos As Integer + Dim X As Long + NumLen = GetBits(5) + 257 + Numdis = GetBits(5) + 1 + NumCod = GetBits(4) + 4 + ReDim Lenght(18) + For X = 0 To NumCod - 1 + Lenght(LenOrder(X)) = GetBits(3) + Next + For X = NumCod To 18 + Lenght(LenOrder(X)) = 0 + Next + If Create_Codes(Bl_Tree, Lenght, 18, MaxBL, MinBL) <> 0 Then + Create_Dynamic_Tree = -1 + Exit Function + End If + ReDim Lenght(NumLen + Numdis) + pos = 0 + Do While pos < NumLen + Numdis + Char = Bit_Reverse(GetBits(MinBL), MinBL) + NuBits = MinBL + Do While Bl_Tree(Char).Lenght <> NuBits + Char = Char + Char + GetBits(1) + NuBits = NuBits + 1 + Loop + Char = Bl_Tree(Char).Code + If Char < 16 Then + Lenght(pos) = Char + pos = pos + 1 + Else + If Char = 16 Then + If pos = 0 Then Create_Dynamic_Tree = -5: Exit Function 'no last lenght + LN = Lenght(pos - 1) + Char = 3 + GetBits(2) + ElseIf Char = 17 Then + Char = 3 + GetBits(3) + LN = 0 + Else + Char = 11 + GetBits(7) + LN = 0 + End If + If pos + Char > NumLen + Numdis Then + Create_Dynamic_Tree = -6 'to many lenghts + Exit Function + End If + Do While Char > 0 + Char = Char - 1 + Lenght(pos) = LN + pos = pos + 1 + Loop + End If + Loop + If Create_Codes(LitLen, Lenght, NumLen - 1, MaxLLenght, MinLLenght) <> 0 Then + Create_Dynamic_Tree = -1 + Exit Function + End If + For X = 0 To Numdis + Lenght(X) = Lenght(X + NumLen) + Next + Create_Dynamic_Tree = Create_Codes(Dist, Lenght, Numdis - 1, MaxDLenght, MinDLenght) +End Function + + +Private Sub Init_Inflate(UncompressedSize As Long) + Dim Temp() + Dim X As Long + ReDim OutStream(UncompressedSize) + Erase LitLen + Erase Dist + Erase DC + Erase LC + 'Create the read order array + Temp() = Array(16, 17, 18, 0, 8, 7, 9, 6, 10, 5, 11, 4, 12, 3, 13, 2, 14, 1, 15) + For X = 0 To UBound(Temp): LenOrder(X) = Temp(X): Next + 'Create the Start lenghts array + Temp() = Array(3, 4, 5, 6, 7, 8, 9, 10, 11, 13, 15, 17, 19, 23, 27, 31, 35, 43, 51, 59, 67, 83, 99, 115, 131, 163, 195, 227, 258) + For X = 0 To UBound(Temp): LC(X).Code = Temp(X): Next + 'Create the Extra lenght bits array + Temp() = Array(0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 5, 5, 5, 5, 0) + For X = 0 To UBound(Temp): LC(X).Lenght = Temp(X): Next + 'Create the distance code array + Temp() = Array(1, 2, 3, 4, 5, 7, 9, 13, 17, 25, 33, 49, 65, 97, 129, 193, 257, 385, 513, 769, 1025, 1537, 2049, 3073, 4097, 6145, 8193, 12289, 16385, 24577, 32769, 49153) + For X = 0 To UBound(Temp): DC(X).Code = Temp(X): Next + 'Create the extra bits distance codes + Temp() = Array(0, 0, 0, 0, 1, 1, 2, 2, 3, 3, 4, 4, 5, 5, 6, 6, 7, 7, 8, 8, 9, 9, 10, 10, 11, 11, 12, 12, 13, 13, 14, 14) + For X = 0 To UBound(Temp): DC(X).Lenght = Temp(X): Next + + OutPos = 0 + Inpos = 0 + For X = 0 To 16 + BitMask(X) = 2 ^ X - 1 + BitVal(X) = 2 ^ X + Next + ByteBuff = 0 + BitNum = 0 +End Sub + +Private Function Create_Codes(tree() As CodesType, Lenghts() As Long, NumCodes As Long, MaxBits As Integer, Minbits As Integer) As Integer + Dim bits(16) As Long + Dim next_code(16) As Long + Dim Code As Long + Dim LN As Long + Dim X As Long +'retrieve the bitlenght count and minimum and maximum bitlenghts + Minbits = 16 + For X = 0 To NumCodes + bits(Lenghts(X)) = bits(Lenghts(X)) + 1 + If Lenghts(X) > MaxBits Then MaxBits = Lenghts(X) + If Lenghts(X) < Minbits And Lenghts(X) > 0 Then Minbits = Lenghts(X) + Next + LN = 1 + For X = 1 To MaxBits + LN = LN + LN + LN = LN - bits(X) + If LN < 0 Then Create_Codes = LN: Exit Function 'Over subscribe, Return negative + Next + Create_Codes = LN + + ReDim tree(2 ^ MaxBits - 1) 'set the right dimensions + Code = 0 + bits(0) = 0 + For X = 1 To MaxBits + Code = (Code + bits(X - 1)) * 2 + next_code(X) = Code + Next + For X = 0 To NumCodes + LN = Lenghts(X) + If LN <> 0 Then + tree(next_code(LN)).Lenght = LN + tree(next_code(LN)).Code = X + next_code(LN) = next_code(LN) + 1 + End If + Next +End Function + +Private Sub PutByte(Char As Byte) + If OutPos > UBound(OutStream) Then ReDim Preserve OutStream(OutPos + 1000) + OutStream(OutPos) = Char + OutPos = OutPos + 1 +End Sub + +Private Function GetBits(Numbits As Integer) As Long + If BitNum < Numbits Then + Do + ByteBuff = ByteBuff + (InStream(Inpos) * BitVal(BitNum)) + BitNum = BitNum + 8 + Inpos = Inpos + 1 + Loop While BitNum < Numbits + End If + GetBits = ByteBuff And BitMask(Numbits) + ByteBuff = Fix(ByteBuff / BitVal(Numbits)) + BitNum = BitNum - Numbits +End Function + +Private Function Bit_Reverse(ByVal Value As Long, ByVal Numbits As Long) + Do While Numbits > 0 + Bit_Reverse = Bit_Reverse * 2 + (Value And 1) + Numbits = Numbits - 1 + Value = Fix(Value / 2) + Loop +End Function + + + + + + diff --git a/src/WebResponse.cls b/src/WebResponse.cls index a24a1ce7..9dece8a7 100644 --- a/src/WebResponse.cls +++ b/src/WebResponse.cls @@ -301,6 +301,34 @@ End Function ' ============================================= ' Private Sub web_LoadValues(web_Headers As String, web_Content As String, web_Body As Variant, web_Request As WebRequest) + + Dim SingleHeader As Variant + Dim ByteArray() As Byte + + ' Extract headers + Set Me.Headers = ExtractHeaders(web_Headers) + + ' Extract cookies + Set Me.Cookies = ExtractCookies(Me.Headers) + + ' Handle GZIP compressed data + For Each SingleHeader In Me.Headers + If SingleHeader("Key") = "Content-Encoding" Or SingleHeader("Key") = "content-encoding" Then + If SingleHeader("Value") = "gzip" Or SingleHeader("Value") = "GZIP" Then + + ByteArray = Me.Body + Call Inflate.Inflate(ByteArray) 'decode data + Me.Body = ByteArray + Me.Content = StrConv(ByteArray, vbUnicode) + web_Content = Me.Content + + Exit For + End If + + End If + + Next SingleHeader + ' Convert content to data by format If web_Request.ResponseFormat <> WebFormat.PlainText Then On Error Resume Next @@ -314,11 +342,7 @@ Private Sub web_LoadValues(web_Headers As String, web_Content As String, web_Bod On Error GoTo 0 End If - ' Extract headers - Set Me.Headers = ExtractHeaders(web_Headers) - ' Extract cookies - Set Me.Cookies = ExtractCookies(Me.Headers) End Sub Private Function web_ExtractStatusFromCurlResponse(web_CurlResponseLines() As String) As Long