kibi-swipl-linux-x64-gnu 1.0.0

package/lib/swipl/library/ext/http/http/http_wrapper.pl

@@ -0,0 +1,559 @@
+/*  Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@vu.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (c)  2002-2017, University of Amsterdam
+                              VU University Amsterdam
+    All rights reserved.
+
+    Redistribution and use in source and binary forms, with or without
+    modification, are permitted provided that the following conditions
+    are met:
+
+    1. Redistributions of source code must retain the above copyright
+       notice, this list of conditions and the following disclaimer.
+
+    2. Redistributions in binary form must reproduce the above copyright
+       notice, this list of conditions and the following disclaimer in
+       the documentation and/or other materials provided with the
+       distribution.
+
+    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
+    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+    POSSIBILITY OF SUCH DAMAGE.
+*/
+
+:- module(httpd_wrapper,
+          [ http_wrapper/5,             % :Goal, +In, +Out, -Conn, +Options
+            http_current_request/1,     % -Request
+            http_peer/2,                % +Request, -PeerIP
+            http_send_header/1,         % +Term
+            http_relative_path/2,       % +AbsPath, -RelPath
+                                        % Internal API
+            http_wrap_spawned/3,        % :Goal, -Request, -Connection
+            http_spawned/1              % +ThreadId
+          ]).
+:- use_module(http_header).
+:- use_module(http_stream).
+:- use_module(http_exception).
+:- use_module(library(lists)).
+:- use_module(library(debug)).
+:- use_module(library(broadcast)).
+
+:- meta_predicate
+    http_wrapper(0, +, +, -, +).
+:- multifile
+    http:request_expansion/2.
+
+/** <module> Server processing of an HTTP request
+
+Most   code   doesn't   need  to   use  this   directly;  instead   use
+library(http/http_server),  which  combines   this  library  with   the
+typical HTTP libraries that most servers need.
+
+This library provides  the  core  of   the  implementation  of  the HTTP
+protocol at the server side and is   mainly intended for *internal use*.
+It   is   used   by    library(thread_httpd)   and   library(inet_httpd)
+(deprecated).
+
+Still, it provides a few  predicates   that  are occasionally useful for
+applications:
+
+  - http_current_request/1 finds the current request for occasional
+    usage in places where it is not available otherwise.
+  - http_peer/2 finds the (IP4) peer address, getting the original
+    address if we are behind a proxy (=X-Forwarded-For=)
+  - http_relative_path/2 can be used to find a relative path from
+    the current request.
+*/
+
+%!  http_wrapper(:Goal, +In, +Out, -Close, +Options) is det.
+%
+%   Simple wrapper to read and decode  an   HTTP  header from `In', call
+%   :Goal while watching for  exceptions  and   send  the  result to the
+%   stream `Out'.
+%
+%   The goal is assumed to write  the reply to `current_output` preceded
+%   by an HTTP header, closed  by  a   blank  line.  The header __must__
+%   contain a Content-type: <type> line.  It   may  optionally contain a
+%   line ``Transfer-encoding: chunked`` to request chunked encoding.
+%
+%   Options:
+%
+%     - request(-Request)
+%       Return the full request to the caller
+%     - byte_count(-Count)
+%       Stream In byte_count/2 after reading the request.
+%     - peer(+Peer)
+%       IP address of client
+%
+%   @arg   Close   Unified   to   one    of   `close`,   ``Keep-Alive``,
+%   spawned(ThreadId) or switch_protocol(:Goal, +SwitchOptions)
+
+http_wrapper(Goal, In, Out, Close, Options) :-
+    status(Id, State0),
+    catch(http_read_request(In, Request0), ReqError, true),
+    (   Request0 == end_of_file
+    ->  Close = close,
+        extend_request(Options, [], _) % return request
+    ;   var(ReqError)
+    ->  byte_count(In, ByteCount),
+        ignore(memberchk(byte_count(ByteCount), Options)),
+        extend_request(Options, Request0, Request1),
+        cgi_open(Out, CGI, cgi_hook, [request(Request1)]),
+        cgi_property(CGI, id(Id)),
+        (   debugging(http(request))
+        ->  memberchk(method(Method), Request1),
+            memberchk(path(Location), Request1),
+            debug(http(request), "[~D] ~w ~w ...", [Id,Method,Location])
+        ;   true
+        ),
+        handler_with_output_to(Goal, Id, Request1, CGI, Error),
+        cgi_close(CGI, Request1, State0, Error, Close)
+    ;   Id = 0,
+        add_header_context(ReqError),
+        (   debugging(http(request))
+        ->  print_message(warning, ReqError)
+        ;   true
+        ),
+        send_error(Out, [], State0, ReqError, Close),
+        extend_request(Options, [], _)
+    ).
+
+add_header_context(error(_,context(_,in_http_request))) :- !.
+add_header_context(_).
+
+status(Id, state0(Thread, CPU, Id)) :-
+    thread_self(Thread),
+    thread_cputime(CPU).
+
+
+%!  http_wrap_spawned(:Goal, +Request, -Close) is det.
+%
+%   Internal  use  only.  Helper  for    wrapping  the  handler  for
+%   http_spawn/2.
+%
+%   @see http_spawned/1, http_spawn/2.
+
+http_wrap_spawned(Goal, Request, Close) :-
+    current_output(CGI),
+    cgi_property(CGI, id(Id)),
+    handler_with_output_to(Goal, Id, -, current_output, Error),
+    (   retract(spawned(ThreadId))
+    ->  Close = spawned(ThreadId)
+    ;   status(Id, State0),
+        catch(cgi_close(CGI, Request, State0, Error, Close),
+              _,
+              Close = close)
+    ).
+
+
+:- thread_local
+    spawned/1.
+
+%!  http_spawned(+ThreadId)
+%
+%   Internal use only. Indicate that the request is handed to thread
+%   ThreadId.
+
+http_spawned(ThreadId) :-
+    assert(spawned(ThreadId)).
+
+
+%!  cgi_close(+CGI, +Request, +State0, +Error, -Close) is det.
+%
+%   The wrapper has completed. Finish the  CGI output. We have three
+%   cases:
+%
+%       * The wrapper delegated the request to a new thread
+%       * The wrapper succeeded
+%       * The wrapper threw an error, non-200 status reply
+%       (e.g., =not_modified=, =moved=) or a request to reply with
+%       the content of a file.
+%
+%   @error socket I/O errors.
+
+cgi_close(_, _, _, _, Close) :-
+    retract(spawned(ThreadId)),
+    !,
+    Close = spawned(ThreadId).
+cgi_close(CGI, _, State0, ok, Close) :-
+    !,
+    catch(cgi_finish(CGI, Status, Close, Bytes), E, true),
+    (   var(E)
+    ->  http_done(Status, ok, Bytes, State0)
+    ;   http_done(500, E, 0, State0),       % TBD: amount written?
+        throw(E)
+    ).
+cgi_close(CGI, Request, Id, http_reply(Status), Close) :-
+    !,
+    cgi_close(CGI, Request, Id, http_reply(Status, []), Close).
+cgi_close(CGI, _Request, _Id, http_reply(hangup, _), close) :-
+    cgi_discard(CGI),
+    close(CGI).
+cgi_close(CGI, Request, Id, http_reply(Status, ExtraHdrOpts), Close) :-
+    cgi_property(CGI, header_codes(Text)),
+    Text \== [],
+    !,
+    http_parse_header(Text, ExtraHdrCGI),
+    cgi_property(CGI, client(Out)),
+    cgi_discard(CGI),
+    close(CGI),
+    append(ExtraHdrCGI, ExtraHdrOpts, ExtraHdr),
+    send_error(Out, Request, Id, http_reply(Status, ExtraHdr), Close).
+cgi_close(CGI, Request, Id, Error, Close) :-
+    cgi_property(CGI, client(Out)),
+    cgi_discard(CGI),
+    close(CGI),
+    send_error(Out, Request, Id, Error, Close).
+
+cgi_finish(CGI, Status, Close, Bytes) :-
+    flush_output(CGI),                      % update the content-length
+    cgi_property(CGI, connection(Close)),
+    cgi_property(CGI, content_length(Bytes)),
+    (   cgi_property(CGI, header(Header)),
+        memberchk(status(Status), Header)
+    ->  true
+    ;   Status = 200
+    ),
+    close(CGI).
+
+%!  send_error(+Out, +Request, +State0, +Error, -Close)
+%
+%   Send status replies and  reply   files.  The =current_output= no
+%   longer points to the CGI stream, but   simply to the socket that
+%   connects us to the client.
+%
+%   @param  State0 is start-status as returned by status/1.  Used to
+%           find CPU usage, etc.
+
+send_error(Out, Request, State0, Error, Close) :-
+    map_exception_to_http_status(Error, Reply, HdrExtra0, Context),
+    update_keep_alive(HdrExtra0, HdrExtra, Request),
+    catch(http_reply(Reply,
+                     Out,
+                     [ content_length(CLen)
+                     | HdrExtra
+                     ],
+                     Context,
+                     Request,
+                     Code),
+          E, true),
+    (   var(E)
+    ->  http_done(Code, Error, CLen, State0)
+    ;   http_done(500,  E, 0, State0),
+        throw(E)                    % is that wise?
+    ),
+    (   Error = http_reply(switching_protocols(Goal, SwitchOptions), _)
+    ->  Close = switch_protocol(Goal, SwitchOptions)
+    ;   memberchk(connection(Close), HdrExtra)
+    ->  true
+    ;   Close = close
+    ).
+
+update_keep_alive(Header0, Header, Request) :-
+    memberchk(connection(C), Header0),
+    !,
+    (   C == close
+    ->  Header = Header0
+    ;   client_wants_close(Request)
+    ->  selectchk(connection(C),     Header0,
+                  connection(close), Header)
+    ;   Header = Header0
+    ).
+update_keep_alive(Header, Header, _).
+
+client_wants_close(Request) :-
+    memberchk(connection(C), Request),
+    !,
+    C == close.
+client_wants_close(Request) :-
+    \+ ( memberchk(http_version(Major-_Minor), Request),
+         Major >= 1
+       ).
+
+
+%!  http_done(+Code, +Status, +BytesSent, +State0) is det.
+%
+%   Provide feedback for logging and debugging   on  how the request
+%   has been completed.
+
+http_done(Code, Status, Bytes, state0(_Thread, CPU0, Id)) :-
+    thread_cputime(CPU1),
+    CPU is CPU1 - CPU0,
+    (   debugging(http(request))
+    ->  debug_request(Code, Status, Id, CPU, Bytes)
+    ;   true
+    ),
+    broadcast(http(request_finished(Id, Code, Status, CPU, Bytes))).
+
+
+%!  handler_with_output_to(:Goal, +Id, +Request, +Output, -Status) is det.
+%
+%   Run Goal with output redirected to   Output. Unifies Status with
+%   =ok=, the error from catch/3  or a term error(goal_failed(Goal),
+%   _).
+%
+%   @param Request  The HTTP request read or '-' for a continuation
+%                   using http_spawn/2.
+
+handler_with_output_to(Goal, Id, Request, current_output, Status) :-
+    !,
+    (   catch(call_handler(Goal, Id, Request), Status, true)
+    ->  (   var(Status)
+        ->  Status = ok
+        ;   true
+        )
+    ;   Status = error(goal_failed(Goal),_)
+    ).
+handler_with_output_to(Goal, Id, Request, Output, Error) :-
+    stream_property(OldOut, alias(current_output)),
+    set_output(Output),
+    handler_with_output_to(Goal, Id, Request, current_output, Error),
+    set_output(OldOut).
+
+call_handler(Goal, _, -) :-            % continuation through http_spawn/2
+    !,
+    call(Goal).
+call_handler(Goal, Id, Request0) :-
+    expand_request(Request0, Request),
+    current_output(CGI),
+    cgi_set(CGI, request(Request)),
+    broadcast(http(request_start(Id, Request))),
+    call(Goal, Request).
+
+%!  thread_cputime(-CPU) is det.
+%
+%   CPU is the CPU time used by the calling thread.
+
+thread_cputime(CPU) :-
+    statistics(cputime, CPU).
+
+%!  cgi_hook(+Event, +CGI) is det.
+%
+%   Hook called from the CGI   processing stream. See http_stream.pl
+%   for details.
+
+:- public cgi_hook/2.
+
+cgi_hook(What, _CGI) :-
+    debug(http(hook), 'Running hook: ~q', [What]),
+    fail.
+cgi_hook(header, CGI) :-
+    cgi_property(CGI, header_codes(HeadText)),
+    cgi_property(CGI, header(Header0)), % see http_send_header/1
+    http_parse_header(HeadText, CgiHeader0),
+    append(Header0, CgiHeader0, CgiHeader),
+    cgi_property(CGI, request(Request)),
+    http_update_connection(CgiHeader, Request, Connection, Header1),
+    http_update_transfer(Request, Header1, Transfer, Header2),
+    http_update_encoding(Header2, Encoding, Header),
+    set_stream(CGI, encoding(Encoding)),
+    cgi_set(CGI, connection(Connection)),
+    cgi_set(CGI, header(Header)),
+    debug(http(transfer_encoding), 'Transfer-encoding: ~w', [Transfer]),
+    cgi_set(CGI, transfer_encoding(Transfer)). % must be LAST
+cgi_hook(send_header, CGI) :-
+    cgi_property(CGI, header(Header)),
+    debug(http(cgi), 'Header: ~q', [Header]),
+    cgi_property(CGI, client(Out)),
+    (   redirect(Header, Action, RedirectHeader)
+    ->  http_status_reply(Action, Out, RedirectHeader, _),
+        cgi_discard(CGI)
+    ;   cgi_property(CGI, transfer_encoding(chunked))
+    ->  http_reply_header(Out, chunked_data, Header)
+    ;   cgi_property(CGI, transfer_encoding(event_stream)),
+        http_reply_header(Out, event_stream, Header),
+        flush_output(Out)
+    ;   cgi_property(CGI, content_length(Len))
+    ->  http_reply_header(Out, cgi_data(Len), Header)
+    ).
+cgi_hook(close, _).
+
+%!  redirect(+Header, -Action, -RestHeader) is semidet.
+%
+%   Detect the CGI =Location=  and   optional  =Status=  headers for
+%   formulating a HTTP redirect.  Redirection is only established if
+%   no =Status= is provided, or =Status= is 3XX.
+
+redirect(Header, Action, RestHeader) :-
+    selectchk(location(To), Header, Header1),
+    (   selectchk(status(Status), Header1, RestHeader)
+    ->  between(300, 399, Status)
+    ;   RestHeader = Header1,
+        Status = 302
+    ),
+    redirect_action(Status, To, Action).
+
+redirect_action(301, To, moved(To)).
+redirect_action(302, To, moved_temporary(To)).
+redirect_action(303, To, see_other(To)).
+
+
+%!  http_send_header(+Header)
+%
+%   This API provides an alternative for writing the header field as
+%   a CGI header. Header has the  format Name(Value), as produced by
+%   http_read_header/2.
+%
+%   @deprecated     Use CGI lines instead
+
+http_send_header(Header) :-
+    current_output(CGI),
+    cgi_property(CGI, header(Header0)),
+    cgi_set(CGI, header([Header|Header0])).
+
+
+%!  expand_request(+Request0, -Request)
+%
+%   Allow  for  general   rewrites   of    a   request   by  calling
+%   http:request_expansion/2.
+
+expand_request(R0, R) :-
+    http:request_expansion(R0, R1),         % Hook
+    R1 \== R0,
+    !,
+    expand_request(R1, R).
+expand_request(R, R).
+
+
+%!  extend_request(+Options, +RequestIn, -Request)
+%
+%   Merge options in the request.
+
+extend_request([], R, R).
+extend_request([request(R)|T], R0, R) :-
+    !,
+    extend_request(T, R0, R).
+extend_request([H|T], R0, R) :-
+    request_option(H),
+    !,
+    extend_request(T, [H|R0], R).
+extend_request([_|T], R0, R) :-
+    extend_request(T, R0, R).
+
+request_option(peer(_)).
+request_option(protocol(_)).
+request_option(pool(_)).
+
+
+%!  http_current_request(-Request) is semidet.
+%
+%   Returns  the  HTTP  request  currently  being  processed.  Fails
+%   silently if there is no current  request. This typically happens
+%   if a goal is run outside the HTTP server context.
+
+http_current_request(Request) :-
+    current_output(CGI),
+    is_cgi_stream(CGI),
+    cgi_property(CGI, request(Request)).
+
+
+%!  http_peer(+Request, -PeerIP:atom) is semidet.
+%
+%   True when PeerIP is the IP address   of  the connection peer. If the
+%   connection is established via a proxy  or   CDN  we  try to find the
+%   initiating peer.  Currently supports:
+%
+%     - =Fastly-client-ip=
+%     - =X-real-ip=
+%     - =X-forwarded-for=
+%     - Direct connections
+%
+%   @bug The =X-forwarded-for=  header  is   problematic.  According  to
+%   [Wikipedia](https://en.wikipedia.org/wiki/X-Forwarded-For),      the
+%   original   client   is   the    _first_,     while    according   to
+%   [AWS](http://docs.aws.amazon.com/elasticloadbalancing/latest/classic/x-forwarded-headers.html)
+%   it is the _last_.
+
+http_peer(Request, Peer) :-
+    memberchk(fastly_client_ip(Peer), Request), !.
+http_peer(Request, Peer) :-
+    memberchk(x_real_ip(Peer), Request), !.
+http_peer(Request, IP) :-
+    memberchk(x_forwarded_for(IP0), Request),
+    !,
+    atomic_list_concat(Parts, ', ', IP0),
+    last(Parts, IP).
+http_peer(Request, IP) :-
+    memberchk(peer(Peer), Request),
+    !,
+    peer_to_ip(Peer, IP).
+
+peer_to_ip(ip(A,B,C,D), IP) :-
+    atomic_list_concat([A,B,C,D], '.', IP).
+
+
+%!  http_relative_path(+AbsPath, -RelPath) is det.
+%
+%   Convert an absolute path (without host, fragment or search) into
+%   a path relative to the current page.   This  call is intended to
+%   create reusable components returning relative   paths for easier
+%   support of reverse proxies.
+
+http_relative_path(Path, RelPath) :-
+    http_current_request(Request),
+    memberchk(path(RelTo), Request),
+    http_relative_path(Path, RelTo, RelPath),
+    !.
+http_relative_path(Path, Path).
+
+http_relative_path(Path, RelTo, RelPath) :-
+    atomic_list_concat(PL, /, Path),
+    atomic_list_concat(RL, /, RelTo),
+    delete_common_prefix(PL, RL, PL1, PL2),
+    to_dot_dot(PL2, DotDot, PL1),
+    atomic_list_concat(DotDot, /, RelPath).
+
+delete_common_prefix([H|T01], [H|T02], T1, T2) :-
+    !,
+    delete_common_prefix(T01, T02, T1, T2).
+delete_common_prefix(T1, T2, T1, T2).
+
+to_dot_dot([], Tail, Tail).
+to_dot_dot([_], Tail, Tail) :- !.
+to_dot_dot([_|T0], ['..'|T], Tail) :-
+    to_dot_dot(T0, T, Tail).
+
+
+                 /*******************************
+                 *         DEBUG SUPPORT        *
+                 *******************************/
+
+%!  debug_request(+Code, +Status, +Id, +CPU0, Bytes)
+%
+%   Emit debugging info after a request completed with Status.
+
+debug_request(Code, ok, Id, CPU, Bytes) :-
+    !,
+    debug(http(request), '[~D] ~w OK (~3f seconds; ~D bytes)',
+          [Id, Code, CPU, Bytes]).
+debug_request(Code, Status, Id, _, Bytes) :-
+    map_exception(Status, Reply),
+    !,
+    debug(http(request), '[~D] ~w ~w; ~D bytes',
+          [Id, Code, Reply, Bytes]).
+debug_request(Code, Except, Id, _, _) :-
+    Except = error(_,_),
+    !,
+    message_to_string(Except, Message),
+    debug(http(request), '[~D] ~w ERROR: ~w',
+          [Id, Code, Message]).
+debug_request(Code, Status, Id, _, Bytes) :-
+    debug(http(request), '[~D] ~w ~w; ~D bytes',
+          [Id, Code, Status, Bytes]).
+
+map_exception(http_reply(Reply), Reply).
+map_exception(http_reply(Reply, _), Reply).
+map_exception(error(existence_error(http_location, Location), _Stack),
+              error(404, Location)).