1 USING: accessors arrays byte-arrays byte-vectors combinators fry
2 http2.hpack.huffman io.encodings.string io.encodings.utf8 locals
3 kernel math math.functions math.bitwise multiline sequences ;
8 { max-size integer initial: 4096 } { dynamic-table initial: { } } ;
9 ! default the max size to 4096 according to RFC7540
11 ERROR: hpack-decode-error error-msg ;
15 ! The static table for hpack compression/decompression,
16 ! from RFC 7541, Appendix A.
17 CONSTANT: static-table {
18 { f f } ! allows indexing to work out properly
23 { ":path" "/index.html" }
33 { "accept-charset" f }
34 { "accept-encoding" "gzip, deflate" }
35 { "accept-language" f }
38 { "access-control-allow-origin" f }
43 { "content-disposition" f }
44 { "content-encoding" f }
45 { "content-language" f }
46 { "content-length" f }
47 { "content-location" f }
58 { "if-modified-since" f }
61 { "if-unmodified-since" f }
66 { "proxy-authenticate" f }
67 { "proxy-authorization" f }
74 { "strict-transport-security" f }
75 { "transfer-encoding" f }
79 { "www-authenticate" f }
82 : header-size ( header -- size )
86 ! gives the index in the dynamic table such that the sum of the
87 ! size of the elements before the index is less than or equal to
88 ! the desired-size, or f if no entries need to be removed to
89 ! attain the desired size
90 :: dynamic-table-remove-index ( dynamic-table desired-size -- i/f )
91 0 dynamic-table [ header-size + dup desired-size >= ] find drop nip
94 ! shrinks the dynamic table size to the given size (size, *not*
95 ! length) (doesn't affect the max-size of the context)
96 : shrink-dynamic-table ( dynamic-table shrink-to -- shrunk-dynamic-table )
97 dupd dynamic-table-remove-index [ head ] when*
100 :: add-header-to-table ( hpack-context header -- updated-context )
101 hpack-context dynamic-table>> hpack-context max-size>>
102 header header-size - shrink-dynamic-table
103 header header-size hpack-context max-size>> <= [ header prefix ] when
104 hpack-context swap >>dynamic-table
107 : set-dynamic-table-size ( hpack-context new-size -- updated-decode-context )
109 [ dup dynamic-table>> ] dip shrink-dynamic-table >>dynamic-table
112 ! check bounds: i < len(static-table++decode-context) and i > 0
113 : check-index-bounds ( index decode-context -- )
114 [ drop 0 > ] [ dynamic-table>> length static-table length + < ] 2bi
115 and [ "invalid index given" hpack-decode-error ] unless ! if not valid throw error
118 : get-header-from-table ( hpack-context table-index -- field )
119 [ swap check-index-bounds ] 2keep
120 dup static-table length < ! check if in static table
121 [ static-table nth nip ]
122 [ static-table length - swap dynamic-table>> nth ]
125 : search-imperfect ( header table -- imperfect/f )
126 swap first '[ _ first = ] find drop
129 : search-given-table ( header table -- imperfect/f perfect/f )
130 [ search-imperfect ] [ index ] 2bi
133 : correct-dynamic-index ( dynamic-index/f -- whole-table-index/f )
134 [ static-table length + ] [ f ] if*
137 : search-static-table ( header -- imperfect/f perfect/f )
138 static-table search-given-table ;
140 : search-dynamic-table ( header hpack-context -- imperfect/f perfect/f )
141 dynamic-table>> search-given-table
142 [ correct-dynamic-index ] bi@
145 : search-table ( header hpack-context -- imperfect/f perfect/f )
146 [ drop search-static-table ] [ search-dynamic-table ] 2bi
147 ! combine results from static and dynamic tables
152 ! assumes the first-byte respects the prefix-length, such that
153 ! the last prefix-length bits are all 0.
154 : encode-integer ( first-byte int prefix-length -- bytes )
156 [ drop bitor 1byte-array ]
157 [ swap over [ bitor 1byte-array >byte-vector ] [ - ] 2bi*
158 [ dup 128 >= ] [ [ 128 mod 128 + over push ] [ 128 /i ] bi ]
159 while over push >byte-array
162 ! encodes a string without huffman encoding.
163 : encode-string-raw ( string -- bytes )
165 0 over length 7 encode-integer
169 : encode-string-huffman ( string -- bytes )
171 128 over length 7 encode-integer
175 :: encode-field ( encode-context header -- updated-context block )
176 header encode-context search-table
177 [ 128 swap 7 encode-integer encode-context swap nipd ]
178 [ [ 64 swap 6 encode-integer ]
179 [ 64 0 6 encode-integer header first encode-string-huffman append
181 header second encode-string-huffman append
182 encode-context header add-header-to-table swap ]
187 ! version of decode integer that tries to be clever for less
188 ! stack stuff, but not sure if it actually is...
189 :: decode-integer ( block current-index prefix-length -- block new-index number )
190 current-index 1 + :> end-index!
191 current-index block nth prefix-length 2^ 1 - [ mask ] keep over =
193 current-index 1 + block [ 7 bit? not ] find-from drop 1 + end-index!
194 current-index 1 + end-index block subseq reverse
195 0 [ 127 mask swap 128 * + ] reduce
198 [ block end-index ] dip ; ! */
201 ! initial version of decode-integer, which closely follows the
202 ! pseudocode from the rfc (RFC 7541, section 5.1)
203 : decode-integer-fragment ( block index I M -- block index+1 I' M+7 block[index+1] )
204 ! increment index and get block[index]
205 [ 1 + 2dup swap nth ] 2dip
206 ! stack: block index+1 block[index+1] I M
207 ! compute I' = (block[index+1] & 127) * 2^M + I
208 pick 127 mask 2 pick ^ * '[ _ + ] dip
211 : decode-integer ( block current-index prefix-length -- block new-index number )
212 ! get the current octet, compute mask, apply mask
213 [ 2dup swap nth ] dip 2^ 1 - [ mask ] keep
215 ! stack: block index I loop?
217 [ 7 bit? ] [ decode-integer-fragment ] do while
218 ! stack: block index I M, get rid of M, we don't need it
220 when ! the prefix matches the mask (exactly all 1s), must loop
221 [ 1 + ] dip ! increment the index before return
224 : decode-raw-string ( block current-index string-length -- block new-index string )
225 over + dup [ pick subseq utf8 decode ] dip swap ;
227 : decode-huffman-string ( block current-index string-length -- block new-index string )
228 over + dup [ pick subseq huffman-decode ] dip swap
231 : decode-string ( block current-index -- block new-index string )
232 [ 7 decode-integer ] [ swap nth 7 bit? ] 2bi
233 [ decode-huffman-string ] [ decode-raw-string ] if ;
235 : decode-literal-header ( decode-context block index index-length -- decode-context block new-index field )
237 ! string name if 0, else indexed
238 [ decode-string ] [ pickd get-header-from-table first ] if-zero
239 [ decode-string ] dip swap 2array
242 ! block will be a byte array
243 :: decode-field ( decode-context block index -- updated-context block new-index field/f )
244 decode-context block index
246 ! indexed header field
247 { [ index block nth 7 bit? ] [ 7 decode-integer
248 decode-context swap get-header-from-table ] }
249 ! Literal header field with incremental indexing
250 { [ index block nth 6 bit? ] [ 6 decode-literal-header
251 [ 2nip add-header-to-table ] 3keep ] }
252 ! dynamic table size update
253 { [ index block nth 5 bit? ] [ 5 decode-integer -rot f
254 [ set-dynamic-table-size ] 3dip ] }
255 ! literal header field without indexing
256 [ 4 decode-literal-header ]
261 ! headers is a sequence of tuples represented the unencoded headers
262 : hpack-encode ( encode-context headers -- updated-context block )
263 [ encode-field ] map concat ;
266 ! should give the updated dtable, and the list of decoded
267 ! header fields. block is the bytestring (byte array) for the header block
268 : hpack-decode ( decode-context block -- updated-context decoded )
269 [let V{ } clone :> decoded-list
270 0 ! index in the block
271 [ 2dup swap length < ] ! check that the block is longer than the index
272 ! call decode-field and add the (possibly) decoded field to the list
273 [ decode-field [ decoded-list push ]
274 [ decoded-list [ "Table size update not at start of header block"
275 hpack-decode-error ] unless-empty ] if* ]
276 ! if the table was not empty, and we didn't get a header, throw an error.
278 2drop decoded-list >array
279 ! double check the header list size?