1/*  Part of SWI-Prolog
   2
   3    Author:        Jan Wielemaker
   4    E-mail:        J.Wielemaker@vu.nl
   5    WWW:           http://www.swi-prolog.org
   6    Copyright (c)  2002-2016, University of Amsterdam
   7                              VU University Amsterdam
   8    All rights reserved.
   9
  10    Redistribution and use in source and binary forms, with or without
  11    modification, are permitted provided that the following conditions
  12    are met:
  13
  14    1. Redistributions of source code must retain the above copyright
  15       notice, this list of conditions and the following disclaimer.
  16
  17    2. Redistributions in binary form must reproduce the above copyright
  18       notice, this list of conditions and the following disclaimer in
  19       the documentation and/or other materials provided with the
  20       distribution.
  21
  22    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  23    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  24    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
  25    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
  26    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
  27    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
  28    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
  29    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
  30    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
  31    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
  32    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
  33    POSSIBILITY OF SUCH DAMAGE.
  34*/
  35
  36:- module(http_header,
  37          [ http_read_request/2,        % +Stream, -Request
  38            http_read_reply_header/2,   % +Stream, -Reply
  39            http_reply/2,               % +What, +Stream
  40            http_reply/3,               % +What, +Stream, +HdrExtra
  41            http_reply/4,               % +What, +Stream, +HdrExtra, -Code
  42            http_reply/5,               % +What, +Stream, +HdrExtra, +Context,
  43                                        % -Code
  44            http_reply/6,               % +What, +Stream, +HdrExtra, +Context,
  45                                        % +Request, -Code
  46            http_reply_header/3,        % +Stream, +What, +HdrExtra
  47            http_status_reply/4,        % +Status, +Out, +HdrExtra, -Code
  48            http_status_reply/5,        % +Status, +Out, +HdrExtra,
  49                                        % +Context, -Code
  50
  51            http_timestamp/2,           % +Time, -HTTP string
  52
  53            http_post_data/3,           % +Stream, +Data, +HdrExtra
  54
  55            http_read_header/2,         % +Fd, -Header
  56            http_parse_header/2,        % +Codes, -Header
  57            http_parse_header_value/3,  % +Header, +HeaderValue, -MediaTypes
  58            http_join_headers/3,        % +Default, +InHdr, -OutHdr
  59            http_update_encoding/3,     % +HeaderIn, -Encoding, -HeaderOut
  60            http_update_connection/4,   % +HeaderIn, +Request, -Connection, -HeaderOut
  61            http_update_transfer/4      % +HeaderIn, +Request, -Transfer, -HeaderOut
  62          ]).
  63:- use_module(library(readutil)).
  64:- use_module(library(debug)).
  65:- use_module(library(error)).
  66:- use_module(library(option)).
  67:- use_module(library(lists)).
  68:- use_module(library(url)).
  69:- use_module(library(uri)).
  70:- use_module(library(memfile)).
  71:- use_module(library(settings)).
  72:- use_module(library(error)).
  73:- use_module(library(pairs)).
  74:- use_module(library(socket)).
  75:- use_module(library(dcg/basics)).
  76:- use_module(html_write).
  77:- use_module(http_exception).
  78:- use_module(mimetype).
  79:- use_module(mimepack).
  80
  81:- multifile
  82    http:status_page/3,             % +Status, +Context, -HTML
  83    http:post_data_hook/3.          % +Data, +Out, +HdrExtra
  84
  85
  86% see http_update_transfer/4.
  87
  88:- setting(http:chunked_transfer, oneof([never,on_request,if_possible]),
  89           on_request, 'When to use Transfer-Encoding: Chunked').
  90
  91
  92/** <module> Handling HTTP headers
  93
  94The library library(http/http_header) provides   primitives  for parsing
  95and composing HTTP headers. Its functionality  is normally hidden by the
  96other parts of the HTTP server and client libraries.
  97*/
  98
  99
 100                 /*******************************
 101                 *          READ REQUEST        *
 102                 *******************************/
 103
 104%!  http_read_request(+FdIn:stream, -Request) is det.
 105%
 106%   Read an HTTP request-header from FdIn and return the broken-down
 107%   request fields as +Name(+Value) pairs  in   a  list.  Request is
 108%   unified to =end_of_file= if FdIn is at the end of input.
 109
 110http_read_request(In, Request) :-
 111    catch(read_line_to_codes(In, Codes), E, true),
 112    (   var(E)
 113    ->  (   Codes == end_of_file
 114        ->  debug(http(header), 'end-of-file', []),
 115            Request = end_of_file
 116        ;   debug(http(header), 'First line: ~s', [Codes]),
 117            Request =  [input(In)|Request1],
 118            phrase(request(In, Request1), Codes),
 119            (   Request1 = [unknown(Text)|_]
 120            ->  string_codes(S, Text),
 121                syntax_error(http_request(S))
 122            ;   true
 123            )
 124        )
 125    ;   message_to_string(E, Msg),
 126        debug(http(request), 'Exception reading 1st line: ~s', [Msg]),
 127        Request = end_of_file
 128    ).
 129
 130
 131%!  http_read_reply_header(+FdIn, -Reply)
 132%
 133%   Read the HTTP reply header. Throws   an exception if the current
 134%   input does not contain a valid reply header.
 135
 136http_read_reply_header(In, [input(In)|Reply]) :-
 137    read_line_to_codes(In, Codes),
 138    (   Codes == end_of_file
 139    ->  debug(http(header), 'end-of-file', []),
 140        throw(error(syntax(http_reply_header, end_of_file), _))
 141    ;   debug(http(header), 'First line: ~s~n', [Codes]),
 142        (   phrase(reply(In, Reply), Codes)
 143        ->  true
 144        ;   atom_codes(Header, Codes),
 145            syntax_error(http_reply_header(Header))
 146        )
 147    ).
 148
 149
 150                 /*******************************
 151                 *        FORMULATE REPLY       *
 152                 *******************************/
 153
 154%!  http_reply(+Data, +Out:stream) is det.
 155%!  http_reply(+Data, +Out:stream, +HdrExtra) is det.
 156%!  http_reply(+Data, +Out:stream, +HdrExtra, -Code) is det.
 157%!  http_reply(+Data, +Out:stream, +HdrExtra, +Context, -Code) is det.
 158%!  http_reply(+Data, +Out:stream, +HdrExtra, +Context, +Request, -Code) is det.
 159%
 160%   Compose  a  complete  HTTP  reply  from   the  term  Data  using
 161%   additional headers from  HdrExtra  to   the  output  stream Out.
 162%   ExtraHeader is a list of Field(Value). Data is one of:
 163%
 164%           * html(HTML)
 165%           HTML tokens as produced by html//1 from html_write.pl
 166%
 167%           * file(+MimeType, +FileName)
 168%           Reply content of FileName using MimeType
 169%
 170%           * file(+MimeType, +FileName, +Range)
 171%           Reply partial content of FileName with given MimeType
 172%
 173%           * tmp_file(+MimeType, +FileName)
 174%           Same as =file=, but do not include modification time
 175%
 176%           * bytes(+MimeType, +Bytes)
 177%           Send a sequence of Bytes with the indicated MimeType.
 178%           Bytes is either a string of character codes 0..255 or
 179%           list of integers in the range 0..255. Out-of-bound codes
 180%           result in a representation error exception.
 181%
 182%           * stream(+In, +Len)
 183%           Reply content of stream.
 184%
 185%           * cgi_stream(+In, +Len)
 186%           Reply content of stream, which should start with an
 187%           HTTP header, followed by a blank line.  This is the
 188%           typical output from a CGI script.
 189%
 190%           * Status
 191%           HTTP status report as defined by http_status_reply/4.
 192%
 193%   @param HdrExtra provides additional reply-header fields, encoded
 194%          as Name(Value). It can also contain a field
 195%          content_length(-Len) to _retrieve_ the
 196%          value of the Content-length header that is replied.
 197%   @param Code is the numeric HTTP status code sent
 198%
 199%   @tbd    Complete documentation
 200
 201http_reply(What, Out) :-
 202    http_reply(What, Out, [connection(close)], _).
 203
 204http_reply(Data, Out, HdrExtra) :-
 205    http_reply(Data, Out, HdrExtra, _Code).
 206
 207http_reply(Data, Out, HdrExtra, Code) :-
 208    http_reply(Data, Out, HdrExtra, [], Code).
 209
 210http_reply(Data, Out, HdrExtra, Context, Code) :-
 211    http_reply(Data, Out, HdrExtra, Context, [method(get)], Code).
 212
 213http_reply(Data, Out, HdrExtra, _Context, Request, Code) :-
 214    byte_count(Out, C0),
 215    memberchk(method(Method), Request),
 216    catch(http_reply_data(Data, Out, HdrExtra, Method, Code), E, true),
 217    !,
 218    (   var(E)
 219    ->  true
 220    ;   E = error(io_error(write, _), _)
 221    ->  byte_count(Out, C1),
 222        Sent is C1 - C0,
 223        throw(error(http_write_short(Data, Sent), _))
 224    ;   E = error(timeout_error(write, _), _)
 225    ->  throw(E)
 226    ;   map_exception_to_http_status(E, Status, NewHdr, NewContext),
 227        http_status_reply(Status, Out, NewHdr, NewContext, Request, Code)
 228    ).
 229http_reply(Status, Out, HdrExtra, Context, Request, Code) :-
 230    http_status_reply(Status, Out, HdrExtra, Context, Request, Code).
 231
 232:- meta_predicate
 233    if_no_head(+, 0).
 234
 235%!  http_reply_data(+Data, +Out, +HdrExtra, +Method, -Code) is semidet.
 236%
 237%   Fails if Data is not a defined   reply-data format, but a status
 238%   term. See http_reply/3 and http_status_reply/6.
 239%
 240%   @error Various I/O errors.
 241
 242http_reply_data(Data, Out, HdrExtra, Method, Code) :-
 243    http_reply_data_(Data, Out, HdrExtra, Method, Code),
 244    flush_output(Out).
 245
 246http_reply_data_(html(HTML), Out, HdrExtra, Method, Code) :-
 247    !,
 248    phrase(reply_header(html(HTML), HdrExtra, Code), Header),
 249    format(Out, '~s', [Header]),
 250    if_no_head(Method, print_html(Out, HTML)).
 251http_reply_data_(file(Type, File), Out, HdrExtra, Method, Code) :-
 252    !,
 253    phrase(reply_header(file(Type, File), HdrExtra, Code), Header),
 254    reply_file(Out, File, Header, Method).
 255http_reply_data_(gzip_file(Type, File), Out, HdrExtra, Method, Code) :-
 256    !,
 257    phrase(reply_header(gzip_file(Type, File), HdrExtra, Code), Header),
 258    reply_file(Out, File, Header, Method).
 259http_reply_data_(file(Type, File, Range), Out, HdrExtra, Method, Code) :-
 260    !,
 261    phrase(reply_header(file(Type, File, Range), HdrExtra, Code), Header),
 262    reply_file_range(Out, File, Header, Range, Method).
 263http_reply_data_(tmp_file(Type, File), Out, HdrExtra, Method, Code) :-
 264    !,
 265    phrase(reply_header(tmp_file(Type, File), HdrExtra, Code), Header),
 266    reply_file(Out, File, Header, Method).
 267http_reply_data_(bytes(Type, Bytes), Out, HdrExtra, Method, Code) :-
 268    !,
 269    phrase(reply_header(bytes(Type, Bytes), HdrExtra, Code), Header),
 270    format(Out, '~s', [Header]),
 271    if_no_head(Method, format(Out, '~s', [Bytes])).
 272http_reply_data_(stream(In, Len), Out, HdrExtra, Method, Code) :-
 273    !,
 274    phrase(reply_header(cgi_data(Len), HdrExtra, Code), Header),
 275    copy_stream(Out, In, Header, Method, 0, end).
 276http_reply_data_(cgi_stream(In, Len), Out, HdrExtra, Method, Code) :-
 277    !,
 278    http_read_header(In, CgiHeader),
 279    seek(In, 0, current, Pos),
 280    Size is Len - Pos,
 281    http_join_headers(HdrExtra, CgiHeader, Hdr2),
 282    phrase(reply_header(cgi_data(Size), Hdr2, Code), Header),
 283    copy_stream(Out, In, Header, Method, 0, end).
 284
 285if_no_head(head, _) :- !.
 286if_no_head(_, Goal) :-
 287    call(Goal).
 288
 289reply_file(Out, _File, Header, head) :-
 290    !,
 291    format(Out, '~s', [Header]).
 292reply_file(Out, File, Header, _) :-
 293    setup_call_cleanup(
 294        open(File, read, In, [type(binary)]),
 295        copy_stream(Out, In, Header, 0, end),
 296        close(In)).
 297
 298reply_file_range(Out, _File, Header, _Range, head) :-
 299    !,
 300    format(Out, '~s', [Header]).
 301reply_file_range(Out, File, Header, bytes(From, To), _) :-
 302    setup_call_cleanup(
 303        open(File, read, In, [type(binary)]),
 304        copy_stream(Out, In, Header, From, To),
 305        close(In)).
 306
 307copy_stream(Out, _, Header, head, _, _) :-
 308    !,
 309    format(Out, '~s', [Header]).
 310copy_stream(Out, In, Header, _, From, To) :-
 311    copy_stream(Out, In, Header, From, To).
 312
 313copy_stream(Out, In, Header, From, To) :-
 314    (   From == 0
 315    ->  true
 316    ;   seek(In, From, bof, _)
 317    ),
 318    peek_byte(In, _),
 319    format(Out, '~s', [Header]),
 320    (   To == end
 321    ->  copy_stream_data(In, Out)
 322    ;   Len is To - From,
 323        copy_stream_data(In, Out, Len)
 324    ).
 325
 326
 327%!  http_status_reply(+Status, +Out, +HdrExtra, -Code) is det.
 328%!  http_status_reply(+Status, +Out, +HdrExtra, +Context, -Code) is det.
 329%!  http_status_reply(+Status, +Out, +HdrExtra, +Context, +Request, -Code) is det.
 330%
 331%   Emit HTML non-200 status reports. Such  requests are always sent
 332%   as UTF-8 documents.
 333%
 334%   Status can be one of the following:
 335%      - authorise(Method)
 336%        Challenge authorization.  Method is one of
 337%        - basic(Realm)
 338%        - digest(Digest)
 339%      - authorise(basic,Realm)
 340%        Same as authorise(basic(Realm)).  Deprecated.
 341%      - bad_request(ErrorTerm)
 342%      - busy
 343%      - created(Location)
 344%      - forbidden(Url)
 345%      - moved(To)
 346%      - moved_temporary(To)
 347%      - no_content
 348%      - not_acceptable(WhyHtml)
 349%      - not_found(Path)
 350%      - method_not_allowed(Method, Path)
 351%      - not_modified
 352%      - resource_error(ErrorTerm)
 353%      - see_other(To)
 354%      - switching_protocols(Goal,Options)
 355%      - server_error(ErrorTerm)
 356%      - unavailable(WhyHtml)
 357
 358http_status_reply(Status, Out, HdrExtra, Code) :-
 359    http_status_reply(Status, Out, HdrExtra, [], Code).
 360
 361http_status_reply(Status, Out, HdrExtra, Context, Code) :-
 362    http_status_reply(Status, Out, HdrExtra, Context, [method(get)], Code).
 363
 364http_status_reply(Status, Out, HdrExtra, Context, Request, Code) :-
 365    option(method(Method), Request, get),
 366    setup_call_cleanup(
 367        set_stream(Out, encoding(utf8)),
 368        status_reply_flush(Status, Out, HdrExtra, Context, Method, Code),
 369        set_stream(Out, encoding(octet))),
 370    !.
 371
 372status_reply_flush(Status, Out, HdrExtra, Context, Method, Code) :-
 373    status_reply(Status, Out, HdrExtra, Context, Method, Code),
 374    flush_output(Out).
 375
 376status_reply(no_content, Out, HdrExtra, _Context, _Method, Code) :-
 377    !,
 378    phrase(reply_header(status(no_content), HdrExtra, Code), Header),
 379    format(Out, '~s', [Header]).
 380status_reply(switching_protocols(_Goal,Options), Out,
 381             HdrExtra0, _Context, _Method, Code) :-
 382    !,
 383    (   option(headers(Extra1), Options)
 384    ->  true
 385    ;   option(header(Extra1), Options, [])
 386    ),
 387    http_join_headers(HdrExtra0, Extra1, HdrExtra),
 388    phrase(reply_header(status(switching_protocols), HdrExtra, Code), Header),
 389    format(Out, '~s', [Header]).
 390status_reply(created(Location), Out, HdrExtra, _Context, Method, Code) :-
 391    !,
 392    phrase(page([ title('201 Created')
 393                ],
 394                [ h1('Created'),
 395                  p(['The document was created ',
 396                     a(href(Location), ' Here')
 397                    ]),
 398                  \address
 399                ]),
 400           HTML),
 401    phrase(reply_header(created(Location, HTML), HdrExtra, Code), Header),
 402    format(Out, '~s', [Header]),
 403    print_html_if_no_head(Method, Out, HTML).
 404status_reply(moved(To), Out, HdrExtra, _Context, Method, Code) :-
 405    !,
 406    phrase(page([ title('301 Moved Permanently')
 407                ],
 408                [ h1('Moved Permanently'),
 409                  p(['The document has moved ',
 410                     a(href(To), ' Here')
 411                    ]),
 412                  \address
 413                ]),
 414           HTML),
 415    phrase(reply_header(moved(To, HTML), HdrExtra, Code), Header),
 416    format(Out, '~s', [Header]),
 417    print_html_if_no_head(Method, Out, HTML).
 418status_reply(moved_temporary(To), Out, HdrExtra, _Context, Method, Code) :-
 419    !,
 420    phrase(page([ title('302 Moved Temporary')
 421                ],
 422                [ h1('Moved Temporary'),
 423                  p(['The document is currently ',
 424                     a(href(To), ' Here')
 425                    ]),
 426                  \address
 427                ]),
 428           HTML),
 429    phrase(reply_header(moved_temporary(To, HTML),
 430                        HdrExtra, Code), Header),
 431    format(Out, '~s', [Header]),
 432    print_html_if_no_head(Method, Out, HTML).
 433status_reply(see_other(To),Out,HdrExtra, _Context, Method, Code) :-
 434    !,
 435    phrase(page([ title('303 See Other')
 436                 ],
 437                 [ h1('See Other'),
 438                   p(['See other document ',
 439                      a(href(To), ' Here')
 440                     ]),
 441                   \address
 442                 ]),
 443            HTML),
 444     phrase(reply_header(see_other(To, HTML), HdrExtra, Code), Header),
 445     format(Out, '~s', [Header]),
 446     print_html_if_no_head(Method, Out, HTML).
 447status_reply(bad_request(ErrorTerm), Out, HdrExtra, _Context, Method, Code) :-
 448    !,
 449    '$messages':translate_message(ErrorTerm, Lines, []),
 450    phrase(page([ title('400 Bad Request')
 451                ],
 452                [ h1('Bad Request'),
 453                  p(\html_message_lines(Lines)),
 454                  \address
 455                ]),
 456           HTML),
 457    phrase(reply_header(status(bad_request, HTML),
 458                        HdrExtra, Code), Header),
 459    format(Out, '~s', [Header]),
 460    print_html_if_no_head(Method, Out, HTML).
 461status_reply(not_found(URL), Out, HdrExtra, Context, Method, Code) :-
 462    !,
 463    status_page_hook(not_found(URL), 404, Context, HTML),
 464    phrase(reply_header(status(not_found, HTML), HdrExtra, Code), Header),
 465    format(Out, '~s', [Header]),
 466    print_html_if_no_head(Method, Out, HTML).
 467status_reply(method_not_allowed(Method, URL), Out, HdrExtra, Context, QMethod, Code) :-
 468    !,
 469    upcase_atom(Method, UMethod),
 470    status_page_hook(method_not_allowed(UMethod,URL), 405, Context, HTML),
 471    phrase(reply_header(status(method_not_allowed, HTML),
 472                        HdrExtra, Code), Header),
 473    format(Out, '~s', [Header]),
 474    if_no_head(QMethod, print_html(Out, HTML)).
 475status_reply(forbidden(URL), Out, HdrExtra, Context, Method, Code) :-
 476    !,
 477    status_page_hook(forbidden(URL), 403, Context, HTML),
 478    phrase(reply_header(status(forbidden, HTML), HdrExtra, Code), Header),
 479    format(Out, '~s', [Header]),
 480    print_html_if_no_head(Method, Out, HTML).
 481status_reply(authorise(basic, ''), Out, HdrExtra, Context, Method, Code) :-
 482    !,
 483    status_reply(authorise(basic), Out, HdrExtra, Context, Method, Code).
 484status_reply(authorise(basic, Realm), Out, HdrExtra, Context, Method, Code) :-
 485    !,
 486    status_reply(authorise(basic(Realm)), Out, HdrExtra, Context,
 487                 Method, Code).
 488status_reply(authorise(Method), Out, HdrExtra, Context, QMethod, Code) :-
 489    !,
 490    status_page_hook(authorise(Method), 401, Context, HTML),
 491    phrase(reply_header(authorise(Method, HTML),
 492                        HdrExtra, Code), Header),
 493    format(Out, '~s', [Header]),
 494    print_html_if_no_head(QMethod, Out, HTML).
 495status_reply(not_modified, Out, HdrExtra, _Context, _Method, Code) :-
 496    !,
 497    phrase(reply_header(status(not_modified), HdrExtra, Code), Header),
 498    format(Out, '~s', [Header]).
 499status_reply(server_error(ErrorTerm), Out, HdrExtra, _Context, Method, Code) :-
 500    in_or_exclude_backtrace(ErrorTerm, ErrorTerm1),
 501    '$messages':translate_message(ErrorTerm1, Lines, []),
 502    phrase(page([ title('500 Internal server error')
 503                ],
 504                [ h1('Internal server error'),
 505                  p(\html_message_lines(Lines)),
 506                  \address
 507                ]),
 508           HTML),
 509    phrase(reply_header(status(server_error, HTML),
 510                        HdrExtra, Code), Header),
 511    format(Out, '~s', [Header]),
 512    print_html_if_no_head(Method, Out, HTML).
 513status_reply(not_acceptable(WhyHTML), Out, HdrExtra, _Context,
 514             Method, Code) :-
 515    !,
 516    phrase(page([ title('406 Not Acceptable')
 517                ],
 518                [ h1('Not Acceptable'),
 519                  WhyHTML,
 520                  \address
 521                ]),
 522           HTML),
 523    phrase(reply_header(status(not_acceptable, HTML), HdrExtra, Code), Header),
 524    format(Out, '~s', [Header]),
 525    print_html_if_no_head(Method, Out, HTML).
 526status_reply(unavailable(WhyHTML), Out, HdrExtra, _Context, Method, Code) :-
 527    !,
 528    phrase(page([ title('503 Service Unavailable')
 529                ],
 530                [ h1('Service Unavailable'),
 531                  WhyHTML,
 532                  \address
 533                ]),
 534           HTML),
 535    phrase(reply_header(status(service_unavailable, HTML), HdrExtra, Code),
 536           Header),
 537    format(Out, '~s', [Header]),
 538    print_html_if_no_head(Method, Out, HTML).
 539status_reply(resource_error(ErrorTerm), Out, HdrExtra, Context, Method, Code) :-
 540    !,
 541    '$messages':translate_message(ErrorTerm, Lines, []),
 542    status_reply(unavailable(p(\html_message_lines(Lines))),
 543                 Out, HdrExtra, Context, Method, Code).
 544status_reply(busy, Out, HdrExtra, Context, Method, Code) :-
 545    !,
 546    HTML = p(['The server is temporarily out of resources, ',
 547              'please try again later']),
 548    http_status_reply(unavailable(HTML), Out, HdrExtra, Context,
 549                      Method, Code).
 550
 551print_html_if_no_head(head, _, _) :- !.
 552print_html_if_no_head(_, Out, HTML) :-
 553    print_html(Out, HTML).
 554
 555%!  status_page_hook(+Term, +Code, +Context, -HTMLTokens) is det.
 556%
 557%   Calls the following two hooks to generate an HTML page from a
 558%   status reply.
 559%
 560%     - http:status_page(Term, Context, HTML)
 561%     - http:status_page(Status, Context, HTML)
 562
 563status_page_hook(Term, Status, Context, HTML) :-
 564    (   http:status_page(Term, Context, HTML)
 565    ;   http:status_page(Status, Context, HTML) % deprecated
 566    ),
 567    !.
 568
 569status_page_hook(authorise(_Method), 401, _Context, HTML):-
 570    phrase(page([ title('401 Authorization Required')
 571                ],
 572                [ h1('Authorization Required'),
 573                  p(['This server could not verify that you ',
 574                     'are authorized to access the document ',
 575                     'requested.  Either you supplied the wrong ',
 576                     'credentials (e.g., bad password), or your ',
 577                     'browser doesn\'t understand how to supply ',
 578                     'the credentials required.'
 579                    ]),
 580                  \address
 581                ]),
 582           HTML).
 583status_page_hook(forbidden(URL), 403, _Context, HTML) :-
 584    phrase(page([ title('403 Forbidden')
 585                ],
 586                [ h1('Forbidden'),
 587                  p(['You don\'t have permission to access ', URL,
 588                     ' on this server'
 589                    ]),
 590                  \address
 591                ]),
 592           HTML).
 593status_page_hook(not_found(URL), 404, _Context, HTML) :-
 594    phrase(page([ title('404 Not Found')
 595                ],
 596                [ h1('Not Found'),
 597                  p(['The requested URL ', tt(URL),
 598                     ' was not found on this server'
 599                    ]),
 600                  \address
 601                ]),
 602           HTML).
 603status_page_hook(method_not_allowed(UMethod,URL), 405, _Context, HTML) :-
 604    phrase(page([ title('405 Method not allowed')
 605                ],
 606                [ h1('Method not allowed'),
 607                  p(['The requested URL ', tt(URL),
 608                     ' does not support method ', tt(UMethod), '.'
 609                    ]),
 610                  \address
 611                ]),
 612           HTML).
 613
 614
 615html_message_lines([]) -->
 616    [].
 617html_message_lines([nl|T]) -->
 618    !,
 619    html([br([])]),
 620    html_message_lines(T).
 621html_message_lines([flush]) -->
 622    [].
 623html_message_lines([Fmt-Args|T]) -->
 624    !,
 625    { format(string(S), Fmt, Args)
 626    },
 627    html([S]),
 628    html_message_lines(T).
 629html_message_lines([Fmt|T]) -->
 630    !,
 631    { format(string(S), Fmt, [])
 632    },
 633    html([S]),
 634    html_message_lines(T).
 635
 636%!  http_join_headers(+Default, +Header, -Out)
 637%
 638%   Append headers from Default to Header if they are not
 639%   already part of it.
 640
 641http_join_headers([], H, H).
 642http_join_headers([H|T], Hdr0, Hdr) :-
 643    functor(H, N, A),
 644    functor(H2, N, A),
 645    member(H2, Hdr0),
 646    !,
 647    http_join_headers(T, Hdr0, Hdr).
 648http_join_headers([H|T], Hdr0, [H|Hdr]) :-
 649    http_join_headers(T, Hdr0, Hdr).
 650
 651
 652%!  http_update_encoding(+HeaderIn, -Encoding, -HeaderOut)
 653%
 654%   Allow for rewrite of the  header,   adjusting  the  encoding. We
 655%   distinguish three options. If  the   user  announces  `text', we
 656%   always use UTF-8 encoding. If   the user announces charset=utf-8
 657%   we  use  UTF-8  and  otherwise  we  use  octet  (raw)  encoding.
 658%   Alternatively we could dynamically choose for ASCII, ISO-Latin-1
 659%   or UTF-8.
 660
 661http_update_encoding(Header0, utf8, [content_type(Type)|Header]) :-
 662    select(content_type(Type0), Header0, Header),
 663    sub_atom(Type0, 0, _, _, 'text/'),
 664    !,
 665    (   sub_atom(Type0, S, _, _, ';')
 666    ->  sub_atom(Type0, 0, S, _, B)
 667    ;   B = Type0
 668    ),
 669    atom_concat(B, '; charset=UTF-8', Type).
 670http_update_encoding(Header, Encoding, Header) :-
 671    memberchk(content_type(Type), Header),
 672    (   (   sub_atom(Type, _, _, _, 'UTF-8')
 673        ;   sub_atom(Type, _, _, _, 'utf-8')
 674        )
 675    ->  Encoding = utf8
 676    ;   mime_type_encoding(Type, Encoding)
 677    ).
 678http_update_encoding(Header, octet, Header).
 679
 680%!  mime_type_encoding(+MimeType, -Encoding) is semidet.
 681%
 682%   Encoding is the (default) character encoding for MimeType.
 683
 684mime_type_encoding('application/json', utf8).
 685mime_type_encoding('application/jsonrequest', utf8).
 686
 687
 688%!  http_update_connection(+CGIHeader, +Request, -Connection, -Header)
 689%
 690%   Merge keep-alive information from  Request   and  CGIHeader into
 691%   Header.
 692
 693http_update_connection(CgiHeader, Request, Connect,
 694                       [connection(Connect)|Rest]) :-
 695    select(connection(CgiConn), CgiHeader, Rest),
 696    !,
 697    connection(Request, ReqConnection),
 698    join_connection(ReqConnection, CgiConn, Connect).
 699http_update_connection(CgiHeader, Request, Connect,
 700                       [connection(Connect)|CgiHeader]) :-
 701    connection(Request, Connect).
 702
 703join_connection(Keep1, Keep2, Connection) :-
 704    (   downcase_atom(Keep1, 'keep-alive'),
 705        downcase_atom(Keep2, 'keep-alive')
 706    ->  Connection = 'Keep-Alive'
 707    ;   Connection = close
 708    ).
 709
 710
 711%!  connection(+Header, -Connection)
 712%
 713%   Extract the desired connection from a header.
 714
 715connection(Header, Close) :-
 716    (   memberchk(connection(Connection), Header)
 717    ->  Close = Connection
 718    ;   memberchk(http_version(1-X), Header),
 719        X >= 1
 720    ->  Close = 'Keep-Alive'
 721    ;   Close = close
 722    ).
 723
 724
 725%!  http_update_transfer(+Request, +CGIHeader, -Transfer, -Header)
 726%
 727%   Decide on the transfer encoding  from   the  Request and the CGI
 728%   header.    The    behaviour    depends      on    the    setting
 729%   http:chunked_transfer. If =never=, even   explitic  requests are
 730%   ignored. If =on_request=, chunked encoding  is used if requested
 731%   through  the  CGI  header  and  allowed    by   the  client.  If
 732%   =if_possible=, chunked encoding is  used   whenever  the  client
 733%   allows for it, which is  interpreted   as  the client supporting
 734%   HTTP 1.1 or higher.
 735%
 736%   Chunked encoding is more space efficient   and allows the client
 737%   to start processing partial results. The drawback is that errors
 738%   lead to incomplete pages instead of  a nicely formatted complete
 739%   page.
 740
 741http_update_transfer(Request, CgiHeader, Transfer, Header) :-
 742    setting(http:chunked_transfer, When),
 743    http_update_transfer(When, Request, CgiHeader, Transfer, Header).
 744
 745http_update_transfer(never, _, CgiHeader, none, Header) :-
 746    !,
 747    delete(CgiHeader, transfer_encoding(_), Header).
 748http_update_transfer(_, _, CgiHeader, none, Header) :-
 749    memberchk(location(_), CgiHeader),
 750    !,
 751    delete(CgiHeader, transfer_encoding(_), Header).
 752http_update_transfer(_, Request, CgiHeader, Transfer, Header) :-
 753    select(transfer_encoding(CgiTransfer), CgiHeader, Rest),
 754    !,
 755    transfer(Request, ReqConnection),
 756    join_transfer(ReqConnection, CgiTransfer, Transfer),
 757    (   Transfer == none
 758    ->  Header = Rest
 759    ;   Header = [transfer_encoding(Transfer)|Rest]
 760    ).
 761http_update_transfer(if_possible, Request, CgiHeader, Transfer, Header) :-
 762    transfer(Request, Transfer),
 763    Transfer \== none,
 764    !,
 765    Header = [transfer_encoding(Transfer)|CgiHeader].
 766http_update_transfer(_, _, CgiHeader, none, CgiHeader).
 767
 768join_transfer(chunked, chunked, chunked) :- !.
 769join_transfer(_, _, none).
 770
 771
 772%!  transfer(+Header, -Connection)
 773%
 774%   Extract the desired connection from a header.
 775
 776transfer(Header, Transfer) :-
 777    (   memberchk(transfer_encoding(Transfer0), Header)
 778    ->  Transfer = Transfer0
 779    ;   memberchk(http_version(1-X), Header),
 780        X >= 1
 781    ->  Transfer = chunked
 782    ;   Transfer = none
 783    ).
 784
 785
 786%!  content_length_in_encoding(+Encoding, +In, -Bytes)
 787%
 788%   Determine hom many bytes are required to represent the data from
 789%   stream In using the given encoding.  Fails if the data cannot be
 790%   represented with the given encoding.
 791
 792content_length_in_encoding(Enc, Stream, Bytes) :-
 793    stream_property(Stream, position(Here)),
 794    setup_call_cleanup(
 795        open_null_stream(Out),
 796        ( set_stream(Out, encoding(Enc)),
 797          catch(copy_stream_data(Stream, Out), _, fail),
 798          flush_output(Out),
 799          byte_count(Out, Bytes)
 800        ),
 801        ( close(Out, [force(true)]),
 802          set_stream_position(Stream, Here)
 803        )).
 804
 805
 806                 /*******************************
 807                 *          POST SUPPORT        *
 808                 *******************************/
 809
 810%!  http_post_data(+Data, +Out:stream, +HdrExtra) is det.
 811%
 812%   Send data on behalf on an HTTP   POST request. This predicate is
 813%   normally called by http_post/4 from   http_client.pl to send the
 814%   POST data to the server.  Data is one of:
 815%
 816%     * html(+Tokens)
 817%     Result of html//1 from html_write.pl
 818%
 819%     * xml(+Term)
 820%     Post the result of xml_write/3 using the Mime-type
 821%     =|text/xml|=
 822%
 823%     * xml(+Type, +Term)
 824%     Post the result of xml_write/3 using the given Mime-type
 825%     and an empty option list to xml_write/3.
 826%
 827%     * xml(+Type, +Term, +Options)
 828%     Post the result of xml_write/3 using the given Mime-type
 829%     and option list for xml_write/3.
 830%
 831%     * file(+File)
 832%     Send contents of a file. Mime-type is determined by
 833%     file_mime_type/2.
 834%
 835%     * file(+Type, +File)
 836%     Send file with content of indicated mime-type.
 837%
 838%     * memory_file(+Type, +Handle)
 839%     Similar to file(+Type, +File), but using a memory file
 840%     instead of a real file.  See new_memory_file/1.
 841%
 842%     * codes(+Codes)
 843%     As codes(text/plain, Codes).
 844%
 845%     * codes(+Type, +Codes)
 846%     Send Codes using the indicated MIME-type.
 847%
 848%     * bytes(+Type, +Bytes)
 849%     Send Bytes using the indicated MIME-type.  Bytes is either a
 850%     string of character codes 0..255 or list of integers in the
 851%     range 0..255.  Out-of-bound codes result in a representation
 852%     error exception.
 853%
 854%     * atom(+Atom)
 855%     As atom(text/plain, Atom).
 856%
 857%     * atom(+Type, +Atom)
 858%     Send Atom using the indicated MIME-type.
 859%
 860%     * cgi_stream(+Stream, +Len) Read the input from Stream which,
 861%     like CGI data starts with a partial HTTP header. The fields of
 862%     this header are merged with the provided HdrExtra fields. The
 863%     first Len characters of Stream are used.
 864%
 865%     * form(+ListOfParameter)
 866%     Send data of the MIME type application/x-www-form-urlencoded as
 867%     produced by browsers issuing a POST request from an HTML form.
 868%     ListOfParameter is a list of Name=Value or Name(Value).
 869%
 870%     * form_data(+ListOfData)
 871%     Send data of the MIME type =|multipart/form-data|= as produced
 872%     by browsers issuing a POST request from an HTML form using
 873%     enctype =|multipart/form-data|=. ListOfData is the same as for
 874%     the List alternative described below. Below is an example.
 875%     Repository, etc. are atoms providing the value, while the last
 876%     argument provides a value from a file.
 877%
 878%       ==
 879%       ...,
 880%       http_post([ protocol(http),
 881%                   host(Host),
 882%                   port(Port),
 883%                   path(ActionPath)
 884%                 ],
 885%                 form_data([ repository = Repository,
 886%                             dataFormat = DataFormat,
 887%                             baseURI    = BaseURI,
 888%                             verifyData = Verify,
 889%                             data       = file(File)
 890%                           ]),
 891%                 _Reply,
 892%                 []),
 893%       ...,
 894%       ==
 895%
 896%     * List
 897%     If the argument is a plain list, it is sent using the MIME type
 898%     multipart/mixed and packed using mime_pack/3. See mime_pack/3
 899%     for details on the argument format.
 900
 901http_post_data(Data, Out, HdrExtra) :-
 902    http:post_data_hook(Data, Out, HdrExtra),
 903    !.
 904http_post_data(html(HTML), Out, HdrExtra) :-
 905    !,
 906    phrase(post_header(html(HTML), HdrExtra), Header),
 907    format(Out, '~s', [Header]),
 908    print_html(Out, HTML).
 909http_post_data(xml(XML), Out, HdrExtra) :-
 910    !,
 911    http_post_data(xml(text/xml, XML, []), Out, HdrExtra).
 912http_post_data(xml(Type, XML), Out, HdrExtra) :-
 913    !,
 914    http_post_data(xml(Type, XML, []), Out, HdrExtra).
 915http_post_data(xml(Type, XML, Options), Out, HdrExtra) :-
 916    !,
 917    setup_call_cleanup(
 918        new_memory_file(MemFile),
 919        (   setup_call_cleanup(
 920                open_memory_file(MemFile, write, MemOut),
 921                xml_write(MemOut, XML, Options),
 922                close(MemOut)),
 923            http_post_data(memory_file(Type, MemFile), Out, HdrExtra)
 924        ),
 925        free_memory_file(MemFile)).
 926http_post_data(file(File), Out, HdrExtra) :-
 927    !,
 928    (   file_mime_type(File, Type)
 929    ->  true
 930    ;   Type = text/plain
 931    ),
 932    http_post_data(file(Type, File), Out, HdrExtra).
 933http_post_data(file(Type, File), Out, HdrExtra) :-
 934    !,
 935    phrase(post_header(file(Type, File), HdrExtra), Header),
 936    format(Out, '~s', [Header]),
 937    setup_call_cleanup(
 938        open(File, read, In, [type(binary)]),
 939        copy_stream_data(In, Out),
 940        close(In)).
 941http_post_data(memory_file(Type, Handle), Out, HdrExtra) :-
 942    !,
 943    phrase(post_header(memory_file(Type, Handle), HdrExtra), Header),
 944    format(Out, '~s', [Header]),
 945    setup_call_cleanup(
 946        open_memory_file(Handle, read, In, [encoding(octet)]),
 947        copy_stream_data(In, Out),
 948        close(In)).
 949http_post_data(codes(Codes), Out, HdrExtra) :-
 950    !,
 951    http_post_data(codes(text/plain, Codes), Out, HdrExtra).
 952http_post_data(codes(Type, Codes), Out, HdrExtra) :-
 953    !,
 954    phrase(post_header(codes(Type, Codes), HdrExtra), Header),
 955    format(Out, '~s', [Header]),
 956    setup_call_cleanup(
 957        set_stream(Out, encoding(utf8)),
 958        format(Out, '~s', [Codes]),
 959        set_stream(Out, encoding(octet))).
 960http_post_data(bytes(Type, Bytes), Out, HdrExtra) :-
 961    !,
 962    phrase(post_header(bytes(Type, Bytes), HdrExtra), Header),
 963    format(Out, '~s~s', [Header, Bytes]).
 964http_post_data(atom(Atom), Out, HdrExtra) :-
 965    !,
 966    http_post_data(atom(text/plain, Atom), Out, HdrExtra).
 967http_post_data(atom(Type, Atom), Out, HdrExtra) :-
 968    !,
 969    phrase(post_header(atom(Type, Atom), HdrExtra), Header),
 970    format(Out, '~s', [Header]),
 971    setup_call_cleanup(
 972        set_stream(Out, encoding(utf8)),
 973        write(Out, Atom),
 974        set_stream(Out, encoding(octet))).
 975http_post_data(cgi_stream(In, _Len), Out, HdrExtra) :-
 976    !,
 977    debug(obsolete, 'Obsolete 2nd argument in cgi_stream(In,Len)', []),
 978    http_post_data(cgi_stream(In), Out, HdrExtra).
 979http_post_data(cgi_stream(In), Out, HdrExtra) :-
 980    !,
 981    http_read_header(In, Header0),
 982    http_update_encoding(Header0, Encoding, Header),
 983    content_length_in_encoding(Encoding, In, Size),
 984    http_join_headers(HdrExtra, Header, Hdr2),
 985    phrase(post_header(cgi_data(Size), Hdr2), HeaderText),
 986    format(Out, '~s', [HeaderText]),
 987    setup_call_cleanup(
 988        set_stream(Out, encoding(Encoding)),
 989        copy_stream_data(In, Out),
 990        set_stream(Out, encoding(octet))).
 991http_post_data(form(Fields), Out, HdrExtra) :-
 992    !,
 993    parse_url_search(Codes, Fields),
 994    length(Codes, Size),
 995    http_join_headers(HdrExtra,
 996                      [ content_type('application/x-www-form-urlencoded')
 997                      ], Header),
 998    phrase(post_header(cgi_data(Size), Header), HeaderChars),
 999    format(Out, '~s', [HeaderChars]),
1000    format(Out, '~s', [Codes]).
1001http_post_data(form_data(Data), Out, HdrExtra) :-
1002    !,
1003    setup_call_cleanup(
1004        new_memory_file(MemFile),
1005        ( setup_call_cleanup(
1006              open_memory_file(MemFile, write, MimeOut),
1007              mime_pack(Data, MimeOut, Boundary),
1008              close(MimeOut)),
1009          size_memory_file(MemFile, Size, octet),
1010          format(string(ContentType),
1011                 'multipart/form-data; boundary=~w', [Boundary]),
1012          http_join_headers(HdrExtra,
1013                            [ mime_version('1.0'),
1014                              content_type(ContentType)
1015                            ], Header),
1016          phrase(post_header(cgi_data(Size), Header), HeaderChars),
1017          format(Out, '~s', [HeaderChars]),
1018          setup_call_cleanup(
1019              open_memory_file(MemFile, read, In, [encoding(octet)]),
1020              copy_stream_data(In, Out),
1021              close(In))
1022        ),
1023        free_memory_file(MemFile)).
1024http_post_data(List, Out, HdrExtra) :-          % multipart-mixed
1025    is_list(List),
1026    !,
1027    setup_call_cleanup(
1028        new_memory_file(MemFile),
1029        ( setup_call_cleanup(
1030              open_memory_file(MemFile, write, MimeOut),
1031              mime_pack(List, MimeOut, Boundary),
1032              close(MimeOut)),
1033          size_memory_file(MemFile, Size, octet),
1034          format(string(ContentType),
1035                 'multipart/mixed; boundary=~w', [Boundary]),
1036          http_join_headers(HdrExtra,
1037                            [ mime_version('1.0'),
1038                              content_type(ContentType)
1039                            ], Header),
1040          phrase(post_header(cgi_data(Size), Header), HeaderChars),
1041          format(Out, '~s', [HeaderChars]),
1042          setup_call_cleanup(
1043              open_memory_file(MemFile, read, In, [encoding(octet)]),
1044              copy_stream_data(In, Out),
1045              close(In))
1046        ),
1047        free_memory_file(MemFile)).
1048
1049%!  post_header(+Data, +HeaderExtra)//
1050%
1051%   Generate the POST header, emitting HeaderExtra, followed by the
1052%   HTTP Content-length and Content-type fields.
1053
1054post_header(html(Tokens), HdrExtra) -->
1055    header_fields(HdrExtra, Len),
1056    content_length(html(Tokens), Len),
1057    content_type(text/html),
1058    "\r\n".
1059post_header(file(Type, File), HdrExtra) -->
1060    header_fields(HdrExtra, Len),
1061    content_length(file(File), Len),
1062    content_type(Type),
1063    "\r\n".
1064post_header(memory_file(Type, File), HdrExtra) -->
1065    header_fields(HdrExtra, Len),
1066    content_length(memory_file(File), Len),
1067    content_type(Type),
1068    "\r\n".
1069post_header(cgi_data(Size), HdrExtra) -->
1070    header_fields(HdrExtra, Len),
1071    content_length(Size, Len),
1072    "\r\n".
1073post_header(codes(Type, Codes), HdrExtra) -->
1074    header_fields(HdrExtra, Len),
1075    content_length(codes(Codes, utf8), Len),
1076    content_type(Type, utf8),
1077    "\r\n".
1078post_header(bytes(Type, Bytes), HdrExtra) -->
1079    header_fields(HdrExtra, Len),
1080    content_length(bytes(Bytes), Len),
1081    content_type(Type),
1082    "\r\n".
1083post_header(atom(Type, Atom), HdrExtra) -->
1084    header_fields(HdrExtra, Len),
1085    content_length(atom(Atom, utf8), Len),
1086    content_type(Type, utf8),
1087    "\r\n".
1088
1089
1090                 /*******************************
1091                 *       OUTPUT HEADER DCG      *
1092                 *******************************/
1093
1094%!  http_reply_header(+Out:stream, +What, +HdrExtra) is det.
1095%
1096%   Create a reply header  using  reply_header//3   and  send  it to
1097%   Stream.
1098
1099http_reply_header(Out, What, HdrExtra) :-
1100    phrase(reply_header(What, HdrExtra, _Code), String),
1101    !,
1102    format(Out, '~s', [String]).
1103
1104%!  reply_header(+Data, +HdrExtra, -Code)// is det.
1105%
1106%   Grammar that realises the HTTP handler for sending Data. Data is
1107%   a  real  data  object  as  described   with  http_reply/2  or  a
1108%   not-200-ok HTTP status reply. The   following status replies are
1109%   defined.
1110%
1111%     * moved(+URL, +HTMLTokens)
1112%     * created(+URL, +HTMLTokens)
1113%     * moved_temporary(+URL, +HTMLTokens)
1114%     * see_other(+URL, +HTMLTokens)
1115%     * status(+Status)
1116%     * status(+Status, +HTMLTokens)
1117%     * authorise(+Method, +Realm, +Tokens)
1118%     * authorise(+Method, +Tokens)
1119%
1120%   @see http_status_reply/4 formulates the not-200-ok HTTP replies.
1121
1122reply_header(string(String), HdrExtra, Code) -->
1123    reply_header(string(text/plain, String), HdrExtra, Code).
1124reply_header(string(Type, String), HdrExtra, Code) -->
1125    vstatus(ok, Code, HdrExtra),
1126    date(now),
1127    header_fields(HdrExtra, CLen),
1128    content_length(codes(String, utf8), CLen),
1129    content_type(Type, utf8),
1130    "\r\n".
1131reply_header(bytes(Type, Bytes), HdrExtra, Code) -->
1132    vstatus(ok, Code, HdrExtra),
1133    date(now),
1134    header_fields(HdrExtra, CLen),
1135    content_length(bytes(Bytes), CLen),
1136    content_type(Type),
1137    "\r\n".
1138reply_header(html(Tokens), HdrExtra, Code) -->
1139    vstatus(ok, Code, HdrExtra),
1140    date(now),
1141    header_fields(HdrExtra, CLen),
1142    content_length(html(Tokens), CLen),
1143    content_type(text/html),
1144    "\r\n".
1145reply_header(file(Type, File), HdrExtra, Code) -->
1146    vstatus(ok, Code, HdrExtra),
1147    date(now),
1148    modified(file(File)),
1149    header_fields(HdrExtra, CLen),
1150    content_length(file(File), CLen),
1151    content_type(Type),
1152    "\r\n".
1153reply_header(gzip_file(Type, File), HdrExtra, Code) -->
1154    vstatus(ok, Code, HdrExtra),
1155    date(now),
1156    modified(file(File)),
1157    header_fields(HdrExtra, CLen),
1158    content_length(file(File), CLen),
1159    content_type(Type),
1160    content_encoding(gzip),
1161    "\r\n".
1162reply_header(file(Type, File, Range), HdrExtra, Code) -->
1163    vstatus(partial_content, Code, HdrExtra),
1164    date(now),
1165    modified(file(File)),
1166    header_fields(HdrExtra, CLen),
1167    content_length(file(File, Range), CLen),
1168    content_type(Type),
1169    "\r\n".
1170reply_header(tmp_file(Type, File), HdrExtra, Code) -->
1171    vstatus(ok, Code, HdrExtra),
1172    date(now),
1173    header_fields(HdrExtra, CLen),
1174    content_length(file(File), CLen),
1175    content_type(Type),
1176    "\r\n".
1177reply_header(cgi_data(Size), HdrExtra, Code) -->
1178    vstatus(ok, Code, HdrExtra),
1179    date(now),
1180    header_fields(HdrExtra, CLen),
1181    content_length(Size, CLen),
1182    "\r\n".
1183reply_header(chunked_data, HdrExtra, Code) -->
1184    vstatus(ok, Code, HdrExtra),
1185    date(now),
1186    header_fields(HdrExtra, _),
1187    (   {memberchk(transfer_encoding(_), HdrExtra)}
1188    ->  ""
1189    ;   transfer_encoding(chunked)
1190    ),
1191    "\r\n".
1192reply_header(moved(To, Tokens), HdrExtra, Code) -->
1193    vstatus(moved, Code, HdrExtra),
1194    date(now),
1195    header_field('Location', To),
1196    header_fields(HdrExtra, CLen),
1197    content_length(html(Tokens), CLen),
1198    content_type(text/html, utf8),
1199    "\r\n".
1200reply_header(created(Location, Tokens), HdrExtra, Code) -->
1201    vstatus(created, Code, HdrExtra),
1202    date(now),
1203    header_field('Location', Location),
1204    header_fields(HdrExtra, CLen),
1205    content_length(html(Tokens), CLen),
1206    content_type(text/html, utf8),
1207    "\r\n".
1208reply_header(moved_temporary(To, Tokens), HdrExtra, Code) -->
1209    vstatus(moved_temporary, Code, HdrExtra),
1210    date(now),
1211    header_field('Location', To),
1212    header_fields(HdrExtra, CLen),
1213    content_length(html(Tokens), CLen),
1214    content_type(text/html, utf8),
1215    "\r\n".
1216reply_header(see_other(To,Tokens),HdrExtra, Code) -->
1217    vstatus(see_other, Code, HdrExtra),
1218    date(now),
1219    header_field('Location',To),
1220    header_fields(HdrExtra, CLen),
1221    content_length(html(Tokens), CLen),
1222    content_type(text/html, utf8),
1223    "\r\n".
1224reply_header(status(Status), HdrExtra, Code) --> % Empty messages: 1xx, 204 and 304
1225    vstatus(Status, Code),
1226    header_fields(HdrExtra, Clen),
1227    { Clen = 0 },
1228    "\r\n".
1229reply_header(status(Status, Tokens), HdrExtra, Code) -->
1230    vstatus(Status, Code),
1231    date(now),
1232    header_fields(HdrExtra, CLen),
1233    content_length(html(Tokens), CLen),
1234    content_type(text/html, utf8),
1235    "\r\n".
1236reply_header(authorise(Method, Tokens), HdrExtra, Code) -->
1237    vstatus(authorise, Code),
1238    date(now),
1239    authenticate(Method),
1240    header_fields(HdrExtra, CLen),
1241    content_length(html(Tokens), CLen),
1242    content_type(text/html, utf8),
1243    "\r\n".
1244
1245%!  vstatus(+Status, -Code)// is det.
1246%!  vstatus(+Status, -Code, +HdrExtra)// is det.
1247%
1248%   Emit the HTTP header for Status
1249
1250vstatus(_Status, Code, HdrExtra) -->
1251    {memberchk(status(Code), HdrExtra)},
1252    !,
1253    vstatus(_NewStatus, Code).
1254vstatus(Status, Code, _) -->
1255    vstatus(Status, Code).
1256
1257vstatus(Status, Code) -->
1258    "HTTP/1.1 ",
1259    status_number(Status, Code),
1260    " ",
1261    status_comment(Status),
1262    "\r\n".
1263
1264%!  status_number(?Status, ?Code)// is semidet.
1265%
1266%   Parse/generate the HTTP status  numbers  and   map  them  to the
1267%   proper name.
1268%
1269%   @see See the source code for supported status names and codes.
1270
1271status_number(Status, Code) -->
1272    { var(Status) },
1273    !,
1274    integer(Code),
1275    { status_number(Status, Code) },
1276    !.
1277status_number(Status, Code) -->
1278    { status_number(Status, Code) },
1279    integer(Code).
1280
1281%!  status_number(+Status:atom, -Code:nonneg) is det.
1282%!  status_number(-Status:atom, +Code:nonneg) is det.
1283%
1284%   Relates a symbolic  HTTP   status  names to their integer Code.
1285%   Each code also needs a rule for status_comment//1.
1286%
1287%   @throws type_error    If Code is instantiated with something other than
1288%                         an integer.
1289%   @throws domain_error  If Code is instantiated with an integer
1290%                         outside of the range [100-599] of defined
1291%                         HTTP status codes.
1292
1293% Unrecognized status codes that are within a defined code class.
1294% RFC 7231 states:
1295%   "[...] a client MUST understand the class of any status code,
1296%    as indicated by the first digit, and treat an unrecognized status code
1297%    as being equivalent to the `x00` status code of that class [...]
1298%   "
1299% @see http://tools.ietf.org/html/rfc7231#section-6
1300
1301status_number(Status, Code):-
1302    nonvar(Status),
1303    !,
1304    status_number_fact(Status, Code).
1305status_number(Status, Code):-
1306    nonvar(Code),
1307    !,
1308    (   between(100, 599, Code)
1309    ->  (   status_number_fact(Status, Code)
1310        ->  true
1311        ;   ClassCode is Code // 100 * 100,
1312            status_number_fact(Status, ClassCode)
1313        )
1314    ;   domain_error(http_code, Code)
1315    ).
1316
1317status_number_fact(continue,                   100).
1318status_number_fact(switching_protocols,        101).
1319status_number_fact(ok,                         200).
1320status_number_fact(created,                    201).
1321status_number_fact(accepted,                   202).
1322status_number_fact(non_authoritative_info,     203).
1323status_number_fact(no_content,                 204).
1324status_number_fact(reset_content,              205).
1325status_number_fact(partial_content,            206).
1326status_number_fact(multiple_choices,           300).
1327status_number_fact(moved,                      301).
1328status_number_fact(moved_temporary,            302).
1329status_number_fact(see_other,                  303).
1330status_number_fact(not_modified,               304).
1331status_number_fact(use_proxy,                  305).
1332status_number_fact(unused,                     306).
1333status_number_fact(temporary_redirect,         307).
1334status_number_fact(bad_request,                400).
1335status_number_fact(authorise,                  401).
1336status_number_fact(payment_required,           402).
1337status_number_fact(forbidden,                  403).
1338status_number_fact(not_found,                  404).
1339status_number_fact(method_not_allowed,         405).
1340status_number_fact(not_acceptable,             406).
1341status_number_fact(request_timeout,            408).
1342status_number_fact(conflict,                   409).
1343status_number_fact(gone,                       410).
1344status_number_fact(length_required,            411).
1345status_number_fact(payload_too_large,          413).
1346status_number_fact(uri_too_long,               414).
1347status_number_fact(unsupported_media_type,     415).
1348status_number_fact(expectation_failed,         417).
1349status_number_fact(upgrade_required,           426).
1350status_number_fact(server_error,               500).
1351status_number_fact(not_implemented,            501).
1352status_number_fact(bad_gateway,                502).
1353status_number_fact(service_unavailable,        503).
1354status_number_fact(gateway_timeout,            504).
1355status_number_fact(http_version_not_supported, 505).
1356
1357
1358%!  status_comment(+Code:atom)// is det.
1359%
1360%   Emit standard HTTP human-readable comment on the reply-status.
1361
1362status_comment(continue) -->
1363    "Continue".
1364status_comment(switching_protocols) -->
1365    "Switching Protocols".
1366status_comment(ok) -->
1367    "OK".
1368status_comment(created) -->
1369    "Created".
1370status_comment(accepted) -->
1371    "Accepted".
1372status_comment(non_authoritative_info) -->
1373    "Non-Authoritative Information".
1374status_comment(no_content) -->
1375    "No Content".
1376status_comment(reset_content) -->
1377    "Reset Content".
1378status_comment(created) -->
1379    "Created".
1380status_comment(partial_content) -->
1381    "Partial content".
1382status_comment(multiple_choices) -->
1383    "Multiple Choices".
1384status_comment(moved) -->
1385    "Moved Permanently".
1386status_comment(moved_temporary) -->
1387    "Moved Temporary".
1388status_comment(see_other) -->
1389    "See Other".
1390status_comment(not_modified) -->
1391    "Not Modified".
1392status_comment(use_proxy) -->
1393    "Use Proxy".
1394status_comment(unused) -->
1395    "Unused".
1396status_comment(temporary_redirect) -->
1397    "Temporary Redirect".
1398status_comment(bad_request) -->
1399    "Bad Request".
1400status_comment(authorise) -->
1401    "Authorization Required".
1402status_comment(payment_required) -->
1403    "Payment Required".
1404status_comment(forbidden) -->
1405    "Forbidden".
1406status_comment(not_found) -->
1407    "Not Found".
1408status_comment(method_not_allowed) -->
1409    "Method Not Allowed".
1410status_comment(not_acceptable) -->
1411    "Not Acceptable".
1412status_comment(request_timeout) -->
1413    "Request Timeout".
1414status_comment(conflict) -->
1415    "Conflict".
1416status_comment(gone) -->
1417    "Gone".
1418status_comment(length_required) -->
1419    "Length Required".
1420status_comment(payload_too_large) -->
1421    "Payload Too Large".
1422status_comment(uri_too_long) -->
1423    "URI Too Long".
1424status_comment(unsupported_media_type) -->
1425    "Unsupported Media Type".
1426status_comment(expectation_failed) -->
1427    "Expectation Failed".
1428status_comment(upgrade_required) -->
1429    "Upgrade Required".
1430status_comment(server_error) -->
1431    "Internal Server Error".
1432status_comment(not_implemented) -->
1433    "Not Implemented".
1434status_comment(bad_gateway) -->
1435    "Bad Gateway".
1436status_comment(service_unavailable) -->
1437    "Service Unavailable".
1438status_comment(gateway_timeout) -->
1439    "Gateway Timeout".
1440status_comment(http_version_not_supported) -->
1441    "HTTP Version Not Supported".
1442
1443authenticate(negotiate(Data)) -->
1444    "WWW-Authenticate: Negotiate ",
1445    { base64(Data, DataBase64),
1446      atom_codes(DataBase64, Codes)
1447    },
1448    string(Codes), "\r\n".
1449authenticate(negotiate) -->
1450    "WWW-Authenticate: Negotiate\r\n".
1451
1452authenticate(basic) -->
1453    !,
1454    "WWW-Authenticate: Basic\r\n".
1455authenticate(basic(Realm)) -->
1456    "WWW-Authenticate: Basic Realm=\"", atom(Realm), "\"\r\n".
1457
1458authenticate(digest) -->
1459    !,
1460    "WWW-Authenticate: Digest\r\n".
1461authenticate(digest(Details)) -->
1462    "WWW-Authenticate: Digest ", atom(Details), "\r\n".
1463
1464
1465date(Time) -->
1466    "Date: ",
1467    (   { Time == now }
1468    ->  now
1469    ;   rfc_date(Time)
1470    ),
1471    "\r\n".
1472
1473modified(file(File)) -->
1474    !,
1475    { time_file(File, Time)
1476    },
1477    modified(Time).
1478modified(Time) -->
1479    "Last-modified: ",
1480    (   { Time == now }
1481    ->  now
1482    ;   rfc_date(Time)
1483    ),
1484    "\r\n".
1485
1486
1487%!  content_length(+Object, ?Len)// is det.
1488%
1489%   Emit the content-length field and (optionally) the content-range
1490%   field.
1491%
1492%   @param Len Number of bytes specified
1493
1494content_length(file(File, bytes(From, To)), Len) -->
1495    !,
1496    { size_file(File, Size),
1497      (   To == end
1498      ->  Len is Size - From,
1499          RangeEnd is Size - 1
1500      ;   Len is To+1 - From,       % To is index of last byte
1501          RangeEnd = To
1502      )
1503    },
1504    content_range(bytes, From, RangeEnd, Size),
1505    content_length(Len, Len).
1506content_length(Reply, Len) -->
1507    { length_of(Reply, Len)
1508    },
1509    "Content-Length: ", integer(Len),
1510    "\r\n".
1511
1512
1513length_of(_, Len) :-
1514    nonvar(Len),
1515    !.
1516length_of(codes(String, Encoding), Len) :-
1517    !,
1518    setup_call_cleanup(
1519        open_null_stream(Out),
1520        ( set_stream(Out, encoding(Encoding)),
1521          format(Out, '~s', [String]),
1522          byte_count(Out, Len)
1523        ),
1524        close(Out)).
1525length_of(atom(Atom, Encoding), Len) :-
1526    !,
1527    setup_call_cleanup(
1528        open_null_stream(Out),
1529        ( set_stream(Out, encoding(Encoding)),
1530          format(Out, '~a', [Atom]),
1531          byte_count(Out, Len)
1532        ),
1533        close(Out)).
1534length_of(file(File), Len) :-
1535    !,
1536    size_file(File, Len).
1537length_of(memory_file(Handle), Len) :-
1538    !,
1539    size_memory_file(Handle, Len, octet).
1540length_of(html(Tokens), Len) :-
1541    !,
1542    html_print_length(Tokens, Len).
1543length_of(bytes(Bytes), Len) :-
1544    !,
1545    (   string(Bytes)
1546    ->  string_length(Bytes, Len)
1547    ;   length(Bytes, Len)          % assuming a list of 0..255
1548    ).
1549length_of(Len, Len).
1550
1551
1552%!  content_range(+Unit:atom, +From:int, +RangeEnd:int, +Size:int)// is det
1553%
1554%   Emit the =|Content-Range|= header  for   partial  content  (206)
1555%   replies.
1556
1557content_range(Unit, From, RangeEnd, Size) -->
1558    "Content-Range: ", atom(Unit), " ",
1559    integer(From), "-", integer(RangeEnd), "/", integer(Size),
1560    "\r\n".
1561
1562content_encoding(Encoding) -->
1563    "Content-Encoding: ", atom(Encoding), "\r\n".
1564
1565transfer_encoding(Encoding) -->
1566    "Transfer-Encoding: ", atom(Encoding), "\r\n".
1567
1568content_type(Type) -->
1569    content_type(Type, _).
1570
1571content_type(Type, Charset) -->
1572    ctype(Type),
1573    charset(Charset),
1574    "\r\n".
1575
1576ctype(Main/Sub) -->
1577    !,
1578    "Content-Type: ",
1579    atom(Main),
1580    "/",
1581    atom(Sub).
1582ctype(Type) -->
1583    !,
1584    "Content-Type: ",
1585    atom(Type).
1586
1587charset(Var) -->
1588    { var(Var) },
1589    !.
1590charset(utf8) -->
1591    !,
1592    "; charset=UTF-8".
1593charset(CharSet) -->
1594    "; charset=",
1595    atom(CharSet).
1596
1597%!  header_field(-Name, -Value)// is det.
1598%!  header_field(+Name, +Value) is det.
1599%
1600%   Process an HTTP request property. Request properties appear as a
1601%   single line in an HTTP header.
1602
1603header_field(Name, Value) -->
1604    { var(Name) },                 % parsing
1605    !,
1606    field_name(Name),
1607    ":",
1608    whites,
1609    read_field_value(ValueChars),
1610    blanks_to_nl,
1611    !,
1612    {   field_to_prolog(Name, ValueChars, Value)
1613    ->  true
1614    ;   atom_codes(Value, ValueChars),
1615        domain_error(Name, Value)
1616    }.
1617header_field(Name, Value) -->
1618    field_name(Name),
1619    ": ",
1620    field_value(Value),
1621    "\r\n".
1622
1623%!  read_field_value(-Codes)//
1624%
1625%   Read a field eagerly upto the next whitespace
1626
1627read_field_value([H|T]) -->
1628    [H],
1629    { \+ code_type(H, space) },
1630    !,
1631    read_field_value(T).
1632read_field_value([]) -->
1633    "".
1634read_field_value([H|T]) -->
1635    [H],
1636    read_field_value(T).
1637
1638
1639%!  http_parse_header_value(+Field, +Value, -Prolog) is semidet.
1640%
1641%   Translate Value in a meaningful Prolog   term. Field denotes the
1642%   HTTP request field for which we   do  the translation. Supported
1643%   fields are:
1644%
1645%     * content_length
1646%     Converted into an integer
1647%     * cookie
1648%     Converted into a list with Name=Value by cookies//1.
1649%     * set_cookie
1650%     Converted into a term set_cookie(Name, Value, Options).
1651%     Options is a list consisting of Name=Value or a single
1652%     atom (e.g., =secure=)
1653%     * host
1654%     Converted to HostName:Port if applicable.
1655%     * range
1656%     Converted into bytes(From, To), where From is an integer
1657%     and To is either an integer or the atom =end=.
1658%     * accept
1659%     Parsed to a list of media descriptions.  Each media is a term
1660%     media(Type, TypeParams, Quality, AcceptExts). The list is
1661%     sorted according to preference.
1662%     * content_disposition
1663%     Parsed into disposition(Name, Attributes), where Attributes is
1664%     a list of Name=Value pairs.
1665%     * content_type
1666%     Parsed into media(Type/SubType, Attributes), where Attributes
1667%     is a list of Name=Value pairs.
1668
1669http_parse_header_value(Field, Value, Prolog) :-
1670    known_field(Field, _),
1671    to_codes(Value, Codes),
1672    parse_header_value(Field, Codes, Prolog).
1673
1674%!  known_field(?FieldName, ?AutoConvert)
1675%
1676%   True if the value of FieldName is   by default translated into a
1677%   Prolog data structure.
1678
1679known_field(content_length,      true).
1680known_field(status,              true).
1681known_field(cookie,              true).
1682known_field(set_cookie,          true).
1683known_field(host,                true).
1684known_field(range,               maybe).
1685known_field(accept,              maybe).
1686known_field(content_disposition, maybe).
1687known_field(content_type,        false).
1688
1689to_codes(In, Codes) :-
1690    (   is_list(In)
1691    ->  Codes = In
1692    ;   atom_codes(In, Codes)
1693    ).
1694
1695%!  field_to_prolog(+Field, +ValueCodes, -Prolog) is semidet.
1696%
1697%   Translate the value string into  a   sensible  Prolog  term. For
1698%   known_fields(_,true), this must succeed. For   =maybe=,  we just
1699%   return the atom if the translation fails.
1700
1701field_to_prolog(Field, Codes, Prolog) :-
1702    known_field(Field, true),
1703    !,
1704    (   parse_header_value(Field, Codes, Prolog0)
1705    ->  Prolog = Prolog0
1706    ).
1707field_to_prolog(Field, Codes, Prolog) :-
1708    known_field(Field, maybe),
1709    parse_header_value(Field, Codes, Prolog0),
1710    !,
1711    Prolog = Prolog0.
1712field_to_prolog(_, Codes, Atom) :-
1713    atom_codes(Atom, Codes).
1714
1715%!  parse_header_value(+Field, +ValueCodes, -Value) is semidet.
1716%
1717%   Parse the value text of an HTTP   field into a meaningful Prolog
1718%   representation.
1719
1720parse_header_value(content_length, ValueChars, ContentLength) :-
1721    number_codes(ContentLength, ValueChars).
1722parse_header_value(status, ValueChars, Code) :-
1723    (   phrase(" ", L, _),
1724        append(Pre, L, ValueChars)
1725    ->  number_codes(Code, Pre)
1726    ;   number_codes(Code, ValueChars)
1727    ).
1728parse_header_value(cookie, ValueChars, Cookies) :-
1729    debug(cookie, 'Cookie: ~s', [ValueChars]),
1730    phrase(cookies(Cookies), ValueChars).
1731parse_header_value(set_cookie, ValueChars, SetCookie) :-
1732    debug(cookie, 'SetCookie: ~s', [ValueChars]),
1733    phrase(set_cookie(SetCookie), ValueChars).
1734parse_header_value(host, ValueChars, Host) :-
1735    (   append(HostChars, [0':|PortChars], ValueChars),
1736        catch(number_codes(Port, PortChars), _, fail)
1737    ->  atom_codes(HostName, HostChars),
1738        Host = HostName:Port
1739    ;   atom_codes(Host, ValueChars)
1740    ).
1741parse_header_value(range, ValueChars, Range) :-
1742    phrase(range(Range), ValueChars).
1743parse_header_value(accept, ValueChars, Media) :-
1744    parse_accept(ValueChars, Media).
1745parse_header_value(content_disposition, ValueChars, Disposition) :-
1746    phrase(content_disposition(Disposition), ValueChars).
1747parse_header_value(content_type, ValueChars, Type) :-
1748    phrase(parse_content_type(Type), ValueChars).
1749
1750field_value(set_cookie(Name, Value, Options)) -->
1751    !,
1752    atom(Name), "=", atom(Value),
1753    value_options(Options, cookie).
1754field_value(disposition(Disposition, Options)) -->
1755    !,
1756    atom(Disposition), value_options(Options, disposition).
1757field_value(Atomic) -->
1758    atom(Atomic).
1759
1760%!  value_options(+List, +Field)//
1761%
1762%   Emit field parameters such as =|; charset=UTF-8|=.  There
1763%   are three versions: a plain _key_ (`secure`), _token_ values
1764%   and _quoted string_ values.  Seems we cannot deduce that from
1765%   the actual value.
1766
1767value_options([], _) --> [].
1768value_options([H|T], Field) -->
1769    "; ", value_option(H, Field),
1770    value_options(T, Field).
1771
1772value_option(secure=true, cookie) -->
1773    !,
1774    "secure".
1775value_option(Name=Value, Type) -->
1776    { string_option(Name, Type) },
1777    !,
1778    atom(Name), "=",
1779    qstring(Value).
1780value_option(Name=Value, Type) -->
1781    { token_option(Name, Type) },
1782    !,
1783    atom(Name), "=", atom(Value).
1784value_option(Name=Value, _Type) -->
1785    atom(Name), "=",
1786    option_value(Value).
1787
1788string_option(filename, disposition).
1789
1790token_option(path, cookie).
1791
1792option_value(Value) -->
1793    { number(Value) },
1794    !,
1795    number(Value).
1796option_value(Value) -->
1797    { (   atom(Value)
1798      ->  true
1799      ;   string(Value)
1800      ),
1801      forall(string_code(_, Value, C),
1802             token_char(C))
1803    },
1804    !,
1805    atom(Value).
1806option_value(Atomic) -->
1807    qstring(Atomic).
1808
1809qstring(Atomic) -->
1810    { string_codes(Atomic, Codes) },
1811    "\"",
1812    qstring_codes(Codes),
1813    "\"".
1814
1815qstring_codes([]) --> [].
1816qstring_codes([H|T]) --> qstring_code(H), qstring_codes(T).
1817
1818qstring_code(C) --> {qstring_esc(C)}, !, "\\", [C].
1819qstring_code(C) --> [C].
1820
1821qstring_esc(0'").
1822qstring_esc(C) :- ctl(C).
1823
1824
1825                 /*******************************
1826                 *        ACCEPT HEADERS        *
1827                 *******************************/
1828
1829:- dynamic accept_cache/2.
1830:- volatile accept_cache/2.
1831
1832parse_accept(Codes, Media) :-
1833    atom_codes(Atom, Codes),
1834    (   accept_cache(Atom, Media0)
1835    ->  Media = Media0
1836    ;   phrase(accept(Media0), Codes),
1837        keysort(Media0, Media1),
1838        pairs_values(Media1, Media2),
1839        assertz(accept_cache(Atom, Media2)),
1840        Media = Media2
1841    ).
1842
1843%!  accept(-Media)// is semidet.
1844%
1845%   Parse an HTTP Accept: header
1846
1847accept([H|T]) -->
1848    blanks,
1849    media_range(H),
1850    blanks,
1851    (   ","
1852    ->  accept(T)
1853    ;   {T=[]}
1854    ).
1855
1856media_range(s(SortQuality,Spec)-media(Type, TypeParams, Quality, AcceptExts)) -->
1857    media_type(Type),
1858    blanks,
1859    (   ";"
1860    ->  blanks,
1861        parameters_and_quality(TypeParams, Quality, AcceptExts)
1862    ;   { TypeParams = [],
1863          Quality = 1.0,
1864          AcceptExts = []
1865        }
1866    ),
1867    { SortQuality is float(-Quality),
1868      rank_specialised(Type, TypeParams, Spec)
1869    }.
1870
1871
1872%!  content_disposition(-Disposition)//
1873%
1874%   Parse Content-Disposition value
1875
1876content_disposition(disposition(Disposition, Options)) -->
1877    token(Disposition), blanks,
1878    value_parameters(Options).
1879
1880%!  parse_content_type(-Type)//
1881%
1882%   Parse  Content-Type  value  into    a  term  media(Type/SubType,
1883%   Parameters).
1884
1885parse_content_type(media(Type, Parameters)) -->
1886    media_type(Type), blanks,
1887    value_parameters(Parameters).
1888
1889
1890%!  rank_specialised(+Type, +TypeParam, -Key) is det.
1891%
1892%   Although the specification linked  above   is  unclear, it seems
1893%   that  more  specialised  types  must   be  preferred  over  less
1894%   specialized ones.
1895%
1896%   @tbd    Is there an official specification of this?
1897
1898rank_specialised(Type/SubType, TypeParams, v(VT, VS, SortVP)) :-
1899    var_or_given(Type, VT),
1900    var_or_given(SubType, VS),
1901    length(TypeParams, VP),
1902    SortVP is -VP.
1903
1904var_or_given(V, Val) :-
1905    (   var(V)
1906    ->  Val = 0
1907    ;   Val = -1
1908    ).
1909
1910media_type(Type/SubType) -->
1911    type(Type), "/", type(SubType).
1912
1913type(_) -->
1914    "*",
1915    !.
1916type(Type) -->
1917    token(Type).
1918
1919parameters_and_quality(Params, Quality, AcceptExts) -->
1920    token(Name),
1921    blanks, "=", blanks,
1922    (   { Name == q }
1923    ->  float(Quality), blanks,
1924        value_parameters(AcceptExts),
1925        { Params = [] }
1926    ;   { Params = [Name=Value|T] },
1927        parameter_value(Value),
1928        blanks,
1929        (   ";"
1930        ->  blanks,
1931            parameters_and_quality(T, Quality, AcceptExts)
1932        ;   { T = [],
1933              Quality = 1.0,
1934              AcceptExts = []
1935            }
1936        )
1937    ).
1938
1939%!  value_parameters(-Params:list) is det.
1940%
1941%   Accept (";" <parameter>)*, returning a list of Name=Value, where
1942%   both Name and Value are atoms.
1943
1944value_parameters([H|T]) -->
1945    ";",
1946    !,
1947    blanks, token(Name), blanks,
1948    (   "="
1949    ->  blanks,
1950        (   token(Value)
1951        ->  []
1952        ;   quoted_string(Value)
1953        ),
1954        { H = (Name=Value) }
1955    ;   { H = Name }
1956    ),
1957    blanks,
1958    value_parameters(T).
1959value_parameters([]) -->
1960    [].
1961
1962parameter_value(Value) --> token(Value), !.
1963parameter_value(Value) --> quoted_string(Value).
1964
1965
1966%!  token(-Name)// is semidet.
1967%
1968%   Process an HTTP header token from the input.
1969
1970token(Name) -->
1971    token_char(C1),
1972    token_chars(Cs),
1973    { atom_codes(Name, [C1|Cs]) }.
1974
1975token_chars([H|T]) -->
1976    token_char(H),
1977    !,
1978    token_chars(T).
1979token_chars([]) --> [].
1980
1981token_char(C) --> [C], { token_char(C) }.
1982
1983token_char(C) :-
1984    \+ ctl(C),
1985    \+ separator_code(C).
1986
1987ctl(C) :- between(0,31,C), !.
1988ctl(127).
1989
1990separator_code(0'().
1991separator_code(0')).
1992separator_code(0'<).
1993separator_code(0'>).
1994separator_code(0'@).
1995separator_code(0',).
1996separator_code(0';).
1997separator_code(0':).
1998separator_code(0'\\).
1999separator_code(0'").
2000separator_code(0'/).
2001separator_code(0'[).
2002separator_code(0']).
2003separator_code(0'?).
2004separator_code(0'=).
2005separator_code(0'{).
2006separator_code(0'}).
2007separator_code(0'\s).
2008separator_code(0'\t).
2009
2010
2011%!  quoted_string(-Text)// is semidet.
2012%
2013%   True if input starts with a quoted string representing Text.
2014
2015quoted_string(Text) -->
2016    "\"",
2017    quoted_text(Codes),
2018    { atom_codes(Text, Codes) }.
2019
2020quoted_text([]) -->
2021    "\"",
2022    !.
2023quoted_text([H|T]) -->
2024    "\\", !, [H],
2025    quoted_text(T).
2026quoted_text([H|T]) -->
2027    [H],
2028    !,
2029    quoted_text(T).
2030
2031
2032%!  header_fields(+Fields, ?ContentLength)// is det.
2033%
2034%   Process a sequence of  [Name(Value),   ...]  attributes  for the
2035%   header. A term content_length(Len) is   special. If instantiated
2036%   it emits the header. If not   it just unifies ContentLength with
2037%   the argument of the content_length(Len)   term.  This allows for
2038%   both sending and retrieving the content-length.
2039
2040header_fields([], _) --> [].
2041header_fields([content_length(CLen)|T], CLen) -->
2042    !,
2043    (   { var(CLen) }
2044    ->  ""
2045    ;   header_field(content_length, CLen)
2046    ),
2047    header_fields(T, CLen).           % Continue or return first only?
2048header_fields([status(_)|T], CLen) -->   % handled by vstatus//3.
2049    !,
2050    header_fields(T, CLen).
2051header_fields([H|T], CLen) -->
2052    { H =.. [Name, Value] },
2053    header_field(Name, Value),
2054    header_fields(T, CLen).
2055
2056
2057%!  field_name(?PrologName)
2058%
2059%   Convert between prolog_name  and  HttpName.   Field  names  are,
2060%   according to RFC 2616, considered  tokens   and  covered  by the
2061%   following definition:
2062%
2063%   ==
2064%   token          = 1*<any CHAR except CTLs or separators>
2065%   separators     = "(" | ")" | "<" | ">" | "@"
2066%                  | "," | ";" | ":" | "\" | <">
2067%                  | "/" | "[" | "]" | "?" | "="
2068%                  | "{" | "}" | SP | HT
2069%   ==
2070
2071:- public
2072    field_name//1.
2073
2074field_name(Name) -->
2075    { var(Name) },
2076    !,
2077    rd_field_chars(Chars),
2078    { atom_codes(Name, Chars) }.
2079field_name(mime_version) -->
2080    !,
2081    "MIME-Version".
2082field_name(Name) -->
2083    { atom_codes(Name, Chars) },
2084    wr_field_chars(Chars).
2085
2086rd_field_chars_no_fold([C|T]) -->
2087    [C],
2088    { rd_field_char(C, _) },
2089    !,
2090    rd_field_chars_no_fold(T).
2091rd_field_chars_no_fold([]) -->
2092    [].
2093
2094rd_field_chars([C0|T]) -->
2095    [C],
2096    { rd_field_char(C, C0) },
2097    !,
2098    rd_field_chars(T).
2099rd_field_chars([]) -->
2100    [].
2101
2102%!  separators(-CharCodes) is det.
2103%
2104%   CharCodes is a list of separators according to RFC2616
2105
2106separators("()<>@,;:\\\"/[]?={} \t").
2107
2108term_expansion(rd_field_char('expand me',_), Clauses) :-
2109
2110    Clauses = [ rd_field_char(0'-, 0'_)
2111              | Cls
2112              ],
2113    separators(SepString),
2114    string_codes(SepString, Seps),
2115    findall(rd_field_char(In, Out),
2116            (   between(32, 127, In),
2117                \+ memberchk(In, Seps),
2118                In \== 0'-,         % 0'
2119                code_type(Out, to_lower(In))),
2120            Cls).
2121
2122rd_field_char('expand me', _).                  % avoid recursion
2123
2124wr_field_chars([C|T]) -->
2125    !,
2126    { code_type(C, to_lower(U)) },
2127    [U],
2128    wr_field_chars2(T).
2129wr_field_chars([]) -->
2130    [].
2131
2132wr_field_chars2([]) --> [].
2133wr_field_chars2([C|T]) -->              % 0'
2134    (   { C == 0'_ }
2135    ->  "-",
2136        wr_field_chars(T)
2137    ;   [C],
2138        wr_field_chars2(T)
2139    ).
2140
2141%!  now//
2142%
2143%   Current time using rfc_date//1.
2144
2145now -->
2146    { get_time(Time)
2147    },
2148    rfc_date(Time).
2149
2150%!  rfc_date(+Time)// is det.
2151%
2152%   Write time according to RFC1123 specification as required by the
2153%   RFC2616 HTTP protocol specs.
2154
2155rfc_date(Time, String, Tail) :-
2156    stamp_date_time(Time, Date, 'UTC'),
2157    format_time(codes(String, Tail),
2158                '%a, %d %b %Y %T GMT',
2159                Date, posix).
2160
2161%!  http_timestamp(+Time:timestamp, -Text:atom) is det.
2162%
2163%   Generate a description of a Time in HTTP format (RFC1123)
2164
2165http_timestamp(Time, Atom) :-
2166    stamp_date_time(Time, Date, 'UTC'),
2167    format_time(atom(Atom),
2168                '%a, %d %b %Y %T GMT',
2169                Date, posix).
2170
2171
2172                 /*******************************
2173                 *         REQUEST DCG          *
2174                 *******************************/
2175
2176request(Fd, [method(Method),request_uri(ReqURI)|Header]) -->
2177    method(Method),
2178    blanks,
2179    nonblanks(Query),
2180    { atom_codes(ReqURI, Query),
2181      request_uri_parts(ReqURI, Header, Rest)
2182    },
2183    request_header(Fd, Rest),
2184    !.
2185request(Fd, [unknown(What)|Header]) -->
2186    string(What),
2187    eos,
2188    !,
2189    {   http_read_header(Fd, Header)
2190    ->  true
2191    ;   Header = []
2192    }.
2193
2194method(get)     --> "GET", !.
2195method(put)     --> "PUT", !.
2196method(head)    --> "HEAD", !.
2197method(post)    --> "POST", !.
2198method(delete)  --> "DELETE", !.
2199method(patch)   --> "PATCH", !.
2200method(options) --> "OPTIONS", !.
2201method(trace)   --> "TRACE", !.
2202
2203%!  request_uri_parts(+RequestURI, -Parts, ?Tail) is det.
2204%
2205%   Process the request-uri, producing the following parts:
2206%
2207%     * path(-Path)
2208%     Decode path information (always present)
2209%     * search(-QueryParams)
2210%     Present if there is a ?name=value&... part of the request uri.
2211%     QueryParams is a Name=Value list.
2212%     * fragment(-Fragment)
2213%     Present if there is a #Fragment.
2214
2215request_uri_parts(ReqURI, [path(Path)|Parts], Rest) :-
2216    uri_components(ReqURI, Components),
2217    uri_data(path, Components, PathText),
2218    uri_encoded(path, Path, PathText),
2219    phrase(uri_parts(Components), Parts, Rest).
2220
2221uri_parts(Components) -->
2222    uri_search(Components),
2223    uri_fragment(Components).
2224
2225uri_search(Components) -->
2226    { uri_data(search, Components, Search),
2227      nonvar(Search),
2228      catch(uri_query_components(Search, Query),
2229            error(syntax_error(_),_),
2230            fail)
2231    },
2232    !,
2233    [ search(Query) ].
2234uri_search(_) --> [].
2235
2236uri_fragment(Components) -->
2237    { uri_data(fragment, Components, String),
2238      nonvar(String),
2239      !,
2240      uri_encoded(fragment, Fragment, String)
2241    },
2242    [ fragment(Fragment) ].
2243uri_fragment(_) --> [].
2244
2245%!  request_header(+In:stream, -Header:list) is det.
2246%
2247%   Read the remainder (after the request-uri)   of  the HTTP header
2248%   and return it as a Name(Value) list.
2249
2250request_header(_, []) -->               % Old-style non-version header
2251    blanks,
2252    eos,
2253    !.
2254request_header(Fd, [http_version(Version)|Header]) -->
2255    http_version(Version),
2256    blanks,
2257    eos,
2258    !,
2259    {   Version = 1-_
2260    ->  http_read_header(Fd, Header)
2261    ;   Header = []
2262    }.
2263
2264http_version(Version) -->
2265    blanks,
2266    "HTTP/",
2267    http_version_number(Version).
2268
2269http_version_number(Major-Minor) -->
2270    integer(Major),
2271    ".",
2272    integer(Minor).
2273
2274
2275                 /*******************************
2276                 *            COOKIES           *
2277                 *******************************/
2278
2279%!  cookies(-List)// is semidet.
2280%
2281%   Translate a cookie description into a list Name=Value.
2282
2283cookies([Name=Value|T]) -->
2284    blanks,
2285    cookie(Name, Value),
2286    !,
2287    blanks,
2288    (   ";"
2289    ->  cookies(T)
2290    ;   { T = [] }
2291    ).
2292cookies(List) -->
2293    string(Skipped),
2294    ";",
2295    !,
2296    { print_message(warning, http(skipped_cookie(Skipped))) },
2297    cookies(List).
2298cookies([]) -->
2299    blanks.
2300
2301cookie(Name, Value) -->
2302    cookie_name(Name),
2303    blanks, "=", blanks,
2304    cookie_value(Value).
2305
2306cookie_name(Name) -->
2307    { var(Name) },
2308    !,
2309    rd_field_chars_no_fold(Chars),
2310    { atom_codes(Name, Chars) }.
2311
2312cookie_value(Value) -->
2313    quoted_string(Value),
2314    !.
2315cookie_value(Value) -->
2316    chars_to_semicolon_or_blank(Chars),
2317    { atom_codes(Value, Chars)
2318    }.
2319
2320chars_to_semicolon_or_blank([H|T]) -->
2321    [H],
2322    { H \== 32, H \== 0'; },
2323    !,
2324    chars_to_semicolon_or_blank(T).
2325chars_to_semicolon_or_blank([]) -->
2326    [].
2327
2328set_cookie(set_cookie(Name, Value, Options)) -->
2329    ws,
2330    cookie(Name, Value),
2331    cookie_options(Options).
2332
2333cookie_options([H|T]) -->
2334    ws,
2335    ";",
2336    ws,
2337    cookie_option(H),
2338    !,
2339    cookie_options(T).
2340cookie_options([]) -->
2341    ws.
2342
2343ws --> " ", !, ws.
2344ws --> [].
2345
2346
2347%!  cookie_option(-Option)// is semidet.
2348%
2349%   True if input represents a valid  Cookie option. Officially, all
2350%   cookie  options  use  the  syntax   <name>=<value>,  except  for
2351%   =secure=.  M$  decided  to  extend  this  to  include  at  least
2352%   =httponly= (only the Gods know what it means).
2353%
2354%   @param  Option  Term of the form Name=Value
2355%   @bug    Incorrectly accepts options without = for M$ compatibility.
2356
2357cookie_option(Name=Value) -->
2358    rd_field_chars(NameChars), ws,
2359    { atom_codes(Name, NameChars) },
2360    (   "="
2361    ->  ws,
2362        chars_to_semicolon(ValueChars),
2363        { atom_codes(Value, ValueChars)
2364        }
2365    ;   { Value = true }
2366    ).
2367
2368chars_to_semicolon([H|T]) -->
2369    [H],
2370    { H \== 32, H \== 0'; },
2371    !,
2372    chars_to_semicolon(T).
2373chars_to_semicolon([]), ";" -->
2374    ws, ";",
2375    !.
2376chars_to_semicolon([H|T]) -->
2377    [H],
2378    chars_to_semicolon(T).
2379chars_to_semicolon([]) -->
2380    [].
2381
2382%!  range(-Range)// is semidet.
2383%
2384%   Process the range header value. Range is currently defined as:
2385%
2386%       * bytes(From, To)
2387%       Where From is an integer and To is either an integer or
2388%       the atom =end=.
2389
2390range(bytes(From, To)) -->
2391    "bytes", whites, "=", whites, integer(From), "-",
2392    (   integer(To)
2393    ->  ""
2394    ;   { To = end }
2395    ).
2396
2397
2398                 /*******************************
2399                 *           REPLY DCG          *
2400                 *******************************/
2401
2402%!  reply(+In, -Reply:list)// is semidet.
2403%
2404%   Process the first line of an HTTP   reply.  After that, read the
2405%   remainder  of  the  header  and    parse  it.  After  successful
2406%   completion, Reply contains the following fields, followed by the
2407%   fields produced by http_read_header/2.
2408%
2409%       * http_version(Major-Minor)
2410%       * status(Code, Status, Comment)
2411%         `Code` is an integer between 100 and 599.
2412%         `Status` is a Prolog internal name.
2413%         `Comment` is the comment following the code
2414%         as it appears in the reply's HTTP status line.
2415%         @see status_number//2.
2416
2417reply(Fd, [http_version(HttpVersion), status(Code, Status, Comment)|Header]) -->
2418    http_version(HttpVersion),
2419    blanks,
2420    (   status_number(Status, Code)
2421    ->  []
2422    ;   integer(Status)
2423    ),
2424    blanks,
2425    string(CommentCodes),
2426    blanks_to_nl,
2427    !,
2428    blanks,
2429    { atom_codes(Comment, CommentCodes),
2430      http_read_header(Fd, Header)
2431    }.
2432
2433
2434                 /*******************************
2435                 *            READ HEADER       *
2436                 *******************************/
2437
2438%!  http_read_header(+Fd, -Header) is det.
2439%
2440%   Read Name: Value lines from FD until an empty line is encountered.
2441%   Field-name are converted to Prolog conventions (all lower, _ instead
2442%   of -): Content-Type: text/html --> content_type(text/html)
2443
2444http_read_header(Fd, Header) :-
2445    read_header_data(Fd, Text),
2446    http_parse_header(Text, Header).
2447
2448read_header_data(Fd, Header) :-
2449    read_line_to_codes(Fd, Header, Tail),
2450    read_header_data(Header, Fd, Tail),
2451    debug(http(header), 'Header = ~n~s~n', [Header]).
2452
2453read_header_data([0'\r,0'\n], _, _) :- !.
2454read_header_data([0'\n], _, _) :- !.
2455read_header_data([], _, _) :- !.
2456read_header_data(_, Fd, Tail) :-
2457    read_line_to_codes(Fd, Tail, NewTail),
2458    read_header_data(Tail, Fd, NewTail).
2459
2460%!  http_parse_header(+Text:codes, -Header:list) is det.
2461%
2462%   Header is a list of Name(Value)-terms representing the structure
2463%   of the HTTP header in Text.
2464%
2465%   @error domain_error(http_request_line, Line)
2466
2467http_parse_header(Text, Header) :-
2468    phrase(header(Header), Text),
2469    debug(http(header), 'Field: ~p', [Header]).
2470
2471header(List) -->
2472    header_field(Name, Value),
2473    !,
2474    { mkfield(Name, Value, List, Tail)
2475    },
2476    blanks,
2477    header(Tail).
2478header([]) -->
2479    blanks,
2480    eos,
2481    !.
2482header(_) -->
2483    string(S), blanks_to_nl,
2484    !,
2485    { string_codes(Line, S),
2486      syntax_error(http_parameter(Line))
2487    }.
2488
2489%!  address//
2490%
2491%   Emit the HTML for the server address on behalve of error and
2492%   status messages (non-200 replies).  Default is
2493%
2494%       ==
2495%       SWI-Prolog httpd at <hostname>
2496%       ==
2497%
2498%   The address can be modified by   providing  a definition for the
2499%   multifile predicate http:http_address//0.
2500
2501:- multifile
2502    http:http_address//0.
2503
2504address -->
2505    http:http_address,
2506    !.
2507address -->
2508    { gethostname(Host) },
2509    html(address([ a(href('http://www.swi-prolog.org'), 'SWI-Prolog'),
2510                   ' httpd at ', Host
2511                 ])).
2512
2513mkfield(host, Host:Port, [host(Host),port(Port)|Tail], Tail) :- !.
2514mkfield(Name, Value, [Att|Tail], Tail) :-
2515    Att =.. [Name, Value].
2516
2517%!  http:http_address// is det.
2518%
2519%   HTML-rule that emits the location of  the HTTP server. This hook
2520%   is called from address//0 to customise   the server address. The
2521%   server address is emitted on non-200-ok replies.
2522
2523%!  http:status_page(+Status, +Context, -HTMLTokens) is semidet.
2524%
2525%   Hook called by http_status_reply/4  and http_status_reply/5 that
2526%   allows for emitting custom error pages   for  the following HTTP
2527%   page types:
2528%
2529%     - 401 - authorise(AuthMethod)
2530%     - 403 - forbidden(URL)
2531%     - 404 - not_found(URL)
2532%     - 405 - method_not_allowed(Method,URL)
2533%
2534%   The hook is tried twice,  first   using  the  status term, e.g.,
2535%   not_found(URL) and than with the code,   e.g.  `404`. The second
2536%   call is deprecated and only exists for compatibility.
2537%
2538%   @arg    Context is the 4th argument of http_status_reply/5, which
2539%           is invoked after raising an exception of the format
2540%           http_reply(Status, HeaderExtra, Context).  The default
2541%           context is `[]` (the empty list).
2542%   @arg    HTMLTokens is a list of tokens as produced by html//1.
2543%           It is passed to print_html/2.
2544
2545
2546                 /*******************************
2547                 *            MESSAGES          *
2548                 *******************************/
2549
2550:- multifile
2551    prolog:message//1,
2552    prolog:error_message//1.
2553
2554prolog:error_message(http_write_short(Data, Sent)) -->
2555    data(Data),
2556    [ ': remote hangup after ~D bytes'-[Sent] ].
2557prolog:error_message(syntax_error(http_request(Request))) -->
2558    [ 'Illegal HTTP request: ~s'-[Request] ].
2559prolog:error_message(syntax_error(http_parameter(Line))) -->
2560    [ 'Illegal HTTP parameter: ~s'-[Line] ].
2561
2562prolog:message(http(skipped_cookie(S))) -->
2563    [ 'Skipped illegal cookie: ~s'-[S] ].
2564
2565data(bytes(MimeType, _Bytes)) -->
2566    !,
2567    [ 'bytes(~p, ...)'-[MimeType] ].
2568data(Data) -->
2569    [ '~p'-[Data] ].