extra/http2/hpack/hpack.factor

   1 USING: accessors arrays byte-arrays byte-vectors combinators
   2 http2.hpack.huffman io.encodings.string io.encodings.utf8 kernel
   3 math math.bitwise multiline sequences ;
   4
   5 IN: http2.hpack
   6
   7 TUPLE: hpack-context
   8     { max-size integer initial: 4096 } { dynamic-table initial: { } } ;
   9     ! default the max size to 4096 according to RFC7540
  10
  11 ERROR: hpack-decode-error error-msg ;
  12
  13 <PRIVATE
  14
  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
  19     { ":authority" f }
  20     { ":method" "GET" }
  21     { ":method" "POST" }
  22     { ":path" "/" }
  23     { ":path" "/index.html" }
  24     { ":scheme" "http" }
  25     { ":scheme" "https" }
  26     { ":status" "200" }
  27     { ":status" "204" }
  28     { ":status" "206" }
  29     { ":status" "304" }
  30     { ":status" "400" }
  31     { ":status" "404" }
  32     { ":status" "500" }
  33     { "accept-charset" f }
  34     { "accept-encoding" "gzip, deflate" }
  35     { "accept-language" f }
  36     { "accept-ranges" f }
  37     { "accept" f }
  38     { "access-control-allow-origin" f }
  39     { "age" f }
  40     { "allow" f }
  41     { "authorization" f }
  42     { "cache-control" f }
  43     { "content-disposition" f }
  44     { "content-encoding" f }
  45     { "content-language" f }
  46     { "content-length" f }
  47     { "content-location" f }
  48     { "content-range" f }
  49     { "content-type" f }
  50     { "cookie" f }
  51     { "date" f }
  52     { "etag" f }
  53     { "expect" f }
  54     { "expires" f }
  55     { "from" f }
  56     { "host" f }
  57     { "if-match" f }
  58     { "if-modified-since" f }
  59     { "if-none-match" f }
  60     { "if-range" f }
  61     { "if-unmodified-since" f }
  62     { "last-modified" f }
  63     { "link" f }
  64     { "location" f }
  65     { "max-forwards" f }
  66     { "proxy-authenticate" f }
  67     { "proxy-authorization" f }
  68     { "range" f }
  69     { "referer" f }
  70     { "refresh" f }
  71     { "retry-after" f }
  72     { "server" f }
  73     { "set-cookie" f }
  74     { "strict-transport-security" f }
  75     { "transfer-encoding" f }
  76     { "user-agent" f }
  77     { "vary" f }
  78     { "via" f }
  79     { "www-authenticate" f }
  80 }
  81
  82 : header-size ( header -- size )
  83     sum-lengths 32 +
  84     ;
  85
  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
  92     ;
  93
  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*
  98     ;
  99
 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
 105     ;
 106
 107 : set-dynamic-table-size ( hpack-context new-size -- updated-decode-context )
 108     [ >>max-size ] keep
 109     [ dup dynamic-table>> ] dip shrink-dynamic-table >>dynamic-table
 110     ;
 111
 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
 116     ;
 117
 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 ]
 123     if ;
 124
 125 : search-imperfect ( header table -- imperfect/f )
 126     swap first '[ _ first = ] find drop
 127     ;
 128
 129 : search-given-table ( header table -- imperfect/f perfect/f )
 130     [ search-imperfect ] [ index ] 2bi
 131     ;
 132
 133 : correct-dynamic-index ( dynamic-index/f -- whole-table-index/f )
 134     [ static-table length + ] [ f ] if*
 135     ;
 136
 137 : search-static-table ( header -- imperfect/f perfect/f )
 138     static-table search-given-table ;
 139
 140 : search-dynamic-table ( header hpack-context --  imperfect/f perfect/f )
 141     dynamic-table>> search-given-table
 142     [ correct-dynamic-index ] bi@
 143     ;
 144
 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
 148     swapd [ or ] 2bi@
 149     ;
 150
 151
 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 )
 155     2^ 1 - 2dup <
 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
 160     ] if ;
 161
 162 ! encodes a string without huffman encoding.
 163 : encode-string-raw ( string -- bytes )
 164     utf8 encode
 165     0 over length 7 encode-integer
 166     prepend
 167     ;
 168
 169 : encode-string-huffman ( string -- bytes )
 170     huffman-encode
 171     128 over length 7 encode-integer
 172     prepend
 173     ;
 174
 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
 180         ] if*
 181         header second encode-string-huffman append
 182         encode-context header add-header-to-table swap ]
 183     if*
 184     ;
 185
 186 ! /*
 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 =
 192     [
 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
 196         +
 197     ] when
 198     [ block end-index ] dip ; ! */
 199
 200 /*
 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
 209     7 + rot ;
 210
 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
 214     over =
 215     ! stack: block index I loop?
 216     [ 0
 217       [ 7 bit? ] [ decode-integer-fragment ] do while
 218       ! stack: block index I M, get rid of M, we don't need it
 219       drop ]
 220     when ! the prefix matches the mask (exactly all 1s), must loop
 221     [ 1 + ] dip ! increment the index before return
 222     ; ! */
 223
 224 : decode-raw-string ( block current-index string-length -- block new-index string )
 225     over + dup [ pick subseq utf8 decode ] dip swap ;
 226
 227 : decode-huffman-string ( block current-index string-length -- block new-index string )
 228     over + dup [ pick subseq huffman-decode ] dip swap
 229     ;
 230
 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 ;
 234
 235 : decode-literal-header ( decode-context block index index-length -- decode-context block new-index field )
 236     decode-integer
 237     ! string name if 0, else indexed
 238     [ decode-string ] [ pickd get-header-from-table first ] if-zero
 239     [ decode-string ] dip swap 2array
 240     ;
 241
 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
 245     {
 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 ]
 257     } cond ;
 258
 259 PRIVATE>
 260
 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 ;
 264
 265
 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.
 277     while
 278     2drop decoded-list >array
 279     ! double check the header list size?
 280     ] ;
 281