1:- module(hpack, [hpack/7,
    2                  hpack_max//5,
    3                  lookup_header/3]).

    9:- use_module(library(apply_macros)).   10:- use_module(library(clpfd)).   11:- use_module(library(when), [when/2]).   12:- use_module(library(delay), [delay/1]).   13:- use_module(library(list_util), [take/3]).   14:- use_module(library(edcg)).   15
   16:- use_module(hpack/static_headers, [static_header/2]).   17:- use_module(hpack/huffman, [atom_huffcodes/2]).   18
   19% Encoding primitives
   20
   21int(Prefix, PrefixL, N) -->
   22    { PrefixShift #= 2^(8 - PrefixL),
   23      N #>= 0,
   24      N #< PrefixShift - 1,
   25      Header #= (Prefix * PrefixShift) + N,
   26      Header in 0..0xFF },
   27    [Header].
   28int(Prefix, PrefixL, N) -->
   29    { PrefixShift #= 2^(8 - PrefixL),
   30      N #>= (PrefixShift - 1),
   31      Nn #= N - (PrefixShift - 1),
   32      Header in 0..0xFF,
   33      Header #= (Prefix * PrefixShift) + (PrefixShift - 1) },
   34    [Header], !, int_(Nn).
   35int_(N) -->
   36    { N #< 2^8 - 1 },
   37    [N], !.
   38int_(N) -->
   39    { N #>= 2^8 - 1,
   40      LSB #= N mod 0b1000_0000,
   41      LSBEncode #= 0b1000_0000 + LSB,
   42      LSBEncode in 0..255,
   43      MSB #= (N - LSB) >> 7 },
   44    [LSBEncode], int_(MSB).
   45
   46has_prefix(Prefix, PrefixL), [C] -->
   47    [C],
   48    { Prefix #= C div (2^(8 - PrefixL)) }.
   49
   50str(S) --> % Literal string
   51    has_prefix(0, 1),
   52    { when(ground(S);ground(Codes), atom_codes(S, Codes)),
   53      delay(length(Codes, L)) },
   54    % parsing hufman-encoded strings gets messed up now, because L is
   55    % unbound, so it will just keep trying increasing values of L but
   56    % it will never work.
   57    % How do we indicate that no value of L can make this work?
   58    int(0, 1, L), Codes, !.
   59str(S) --> % Huffman-encoded string
   60    has_prefix(1, 1),
   61    { when(ground(S);ground(HuffmanCodes), atom_huffcodes(S, HuffmanCodes)),
   62      delay(length(HuffmanCodes, L)) },
   63    int(1, 1, L), HuffmanCodes.
   64
   65% just for testing
   66huffstr(S) --> % Huffman-encoded string
   67    has_prefix(1, 1),
   68    { when(ground(S);ground(HuffmanCodes), atom_huffcodes(S, HuffmanCodes)),
   69      delay(length(HuffmanCodes, L)) },
   70    int(1, 1, L), HuffmanCodes.
   71
   72% Encoding headers
   73
   74:- op(0, fx, table). % undefine table operator to make =table= acc work
   75edcg:acc_info(table_size, NewSize, _In, NewSize, true).
   76edcg:acc_info(table, Ts-(K-V), Dt0, Dt1, insert_header(Ts, Dt0, K-V, Dt1)).
   77
   78edcg:pred_info(literal_header_inc_idx, 1, [table_size, table, dcg]).
   79edcg:pred_info(hpack, 1, [table_size, table, dcg]).
   80edcg:pred_info(dynamic_size_update, 1, [table_size, table, dcg]).
   81edcg:pred_info(header, 1, [table_size, table, dcg]).
   82
   83indexed_header(K-V, Dt) -->
   84    { when(ground(K-V);ground(Idx), lookup_header(Dt, K-V, Idx)) },
   85    int(1, 1, Idx), !.
   86
   87literal_header_inc_idx(K-V) -->>
   88    /(Ts, table_size), /(Dt0, table),
   89    { when(ground(K-V);ground(KeyIdx), lookup_header(Dt0, K-_, KeyIdx)),
   90      KeyIdx #> 0 },
   91    [Ts-(K-V)]:table,
   92    int(1, 2, KeyIdx):dcg, str(V):dcg, !.
   93literal_header_inc_idx(K-V) -->>
   94    /(Ts, table_size),
   95    [Ts-(K-V)]:table,
   96    int(1, 2, 0):dcg, str(K):dcg, str(V):dcg, !.
   97
   98literal_header_wo_idx(K-V, Dt) -->
   99    { when(ground(K-V);ground(KeyIdx), lookup_header(Dt, K-_, KeyIdx)),
  100      KeyIdx #> 0 },
  101    int(0, 4, KeyIdx), str(V), !.
  102literal_header_wo_idx(K-V, _) -->
  103    int(0, 4, 0), str(K), str(V), !.
  104
  105literal_header_never_idx(K-V, Dt) -->
  106    { when(ground(K-V);ground(KeyIdx), lookup_header(Dt, K-_, KeyIdx)) },
  107    int(1, 4, KeyIdx), str(V), !.
  108literal_header_never_idx(K-V, _) -->
  109    int(1, 4, 0), str(K), str(V), !.
  110
  111% Header lookups

 lookup_header(+DynamicTable, +NameValue, -Index) is semidet

True when Index is the table index for the header with name Name & value Value, given the dynamic table DynamicTable.

  117lookup_header(_Dt, KV, Idx) :-
  118    static_header(Idx, KV).
  119lookup_header(Dt, KV, Idx) :-
  120    DIdx #= Idx - 61,
  121    nth1(DIdx, Dt, KV), !.
  122
  123insert_header(MaxSize, Dt0, K-V, Dt1) :-
  124    when(ground(K-V),
  125         keep_fitting(MaxSize, [K-V|Dt0], Dt1)).
  126
  127keep_fitting(Max, Lst, Fitting) :-
  128    keep_fitting(Max, 0, Lst, Fitting).
  129keep_fitting(_, _, [], []) :- !.
  130keep_fitting(Max, Cur, [K-V|Rst], [K-V|FitRest]) :-
  131    write_length(K, Kl, []), write_length(V, Vl, []),
  132    S #= Kl + Vl + 32, % "size" = # of bytes + 32 for some reason
  133    NewCur #= Cur + S,
  134    NewCur #=< Max, !,
  135    keep_fitting(Max, NewCur, Rst, FitRest).
  136keep_fitting(_, _, _, []).
  137
  138dynamic_size_update(NewSize) -->>
  139    int(1, 3, NewSize):dcg,
  140    [NewSize]:table_size,
  141    /(DT0, table),
  142    { keep_fitting(NewSize, DT0, DT1) },
  143    /(table, DT1).
  144
  145header(indexed(H)) -->>
  146    /(DT0, table), indexed_header(H, DT0):dcg.
  147header(literal_inc(H)) -->> literal_header_inc_idx(H).
  148header(literal_without(H)) -->>
  149    /(DT0, table), literal_header_wo_idx(H, DT0):dcg.
  150header(literal_never(H)) -->>
  151    /(DT0, table), literal_header_never_idx(H, DT0):dcg.
  152header(size_update(Size)) -->> dynamic_size_update(Size).
  153
  154
  155%! hpack(?Tables, ?Headers:list)//
  156%  DCG for recognizing an HPACK header.
  157%
  158%  @arg Tables =| = TableSize-InTable-OutTable|=
  159%        =TableSize= is the maximum size of the dynamic table, =InTable= is
  160%        the dynamic table before recognizing =Headers= and =OutTable= is
  161%        the dynamic table after.
  162%  @arg Headers the list of HTTP headers.
  163%        Headers are in the format =|Type(Name-Value)|=, where =Type= is
  164%        one of =indexed=, =literal_inc=, =literal_without=, and
  165%        =literal_never=, depending on how the header is to be indexed.
  166%  @see https://httpwg.org/specs/rfc7541.html
  167%  @tbd Make headers more ergonomic -- maybe not wrapped in a functor
  168%        indicating the mode, but not sure how else to allow control of
  169%        what's indexed & what isn't?
  170hpack([Header|Headers]) -->>
  171    header(Header), !, hpack(Headers).
  172hpack([]) -->> [].

 hpack_max(+MaxSize:integer, +Headers:list, ?TableInfo, -Leftover, -Size)//

like hpack, but maintain a maximum size for the header tables

  176hpack_max(Max, [Header|Headers], SizeIn-TableIn-SizeOut-TableOut, Leftover, BytesL) -->
  177    { phrase(hpack([Header], SizeIn, Size1, TableIn, Table1), HBs),
  178      length(HBs, HBL), NextL is BytesL + HBL,
  179      Max >= NextL, ! },
  180    HBs,
  181    hpack_max(Max, Headers, Size1-Table1-SizeOut-TableOut, Leftover, NextL).
  182hpack_max(_, Headers, S-T-S-T, Headers, _) --> []