View source with raw comments or as raw
    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-2014, University of Amsterdam
    7    All rights reserved.
    8
    9    Redistribution and use in source and binary forms, with or without
   10    modification, are permitted provided that the following conditions
   11    are met:
   12
   13    1. Redistributions of source code must retain the above copyright
   14       notice, this list of conditions and the following disclaimer.
   15
   16    2. Redistributions in binary form must reproduce the above copyright
   17       notice, this list of conditions and the following disclaimer in
   18       the documentation and/or other materials provided with the
   19       distribution.
   20
   21    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   22    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   23    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   24    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   25    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   26    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   27    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   28    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   29    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   30    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   31    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   32    POSSIBILITY OF SUCH DAMAGE.
   33*/
   34
   35:- module(xpce_httpd,
   36          [ http_current_server/2,      % ?:Goal, ?Port
   37            http_server/2               % :Goal, :Options
   38          ]).   39:- use_module(library(pce)).   40:- use_module(http_header).   41:- use_module(library(debug)).   42:- use_module(http_wrapper).   43:- use_module(library(lists)).   44
   45:- meta_predicate
   46    http_server(:, ?),
   47    http_server(:, ?, +).

Process HTTP requests using XPCE sockets

deprecated
-
This was useful when multi-threading was poorly supported. New code should use library(http/thread_httpd). */
   55%       @http_servers: keep track of them and avoid the servers being
   56%       garbage collected.
   57
   58:- pce_global(@http_servers, new(chain)).
   59
   60%:- debug(connection).
   61
   62http_current_server(Goal, Port) :-
   63    object(@open_sockets),
   64    chain_list(@open_sockets, Sockets),
   65    member(Socket, Sockets),
   66    send(Socket, instance_of, interactive_httpd),
   67    get(Socket, goal, Goal),
   68    get(Socket, address, Port).
 http_server(:Goal, +Options) is det
Start server at given or arbitrary port.
   74http_server(Goal, Options) :-
   75    select(port(Port), Options, Options1),
   76    !,
   77    http_server(Goal, Port, Options1).
   78http_server(_Goal, _Options) :-
   79    throw(error(existence_error(option, port), _)).
   80
   81http_server(Goal, Port, _Options) :-
   82    strip_module(Goal, M, PlainGoal),
   83    (   var(Port)
   84    ->  new(X, interactive_httpd(M:PlainGoal)),
   85        get(X, address, Port)
   86    ;   new(_, interactive_httpd(M:PlainGoal, Port))
   87    ).
   88
   89/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
   90XPCE based socket handling for   generic HTTP interface infra-structure.
   91This module acts as a replacement for inetd_httpd, which allows a Prolog
   92process to acts as an inet-driven HTTP server.
   93
   94Using this module the user can easily  debug HTTP connections or provide
   95services while running the XPCE GUI.
   96- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
   97
   98:- pce_begin_class(interactive_httpd, socket,
   99                   "Prolog HTTP debugger").
  100
  101variable(allowed_hosts, chain*,  both, "Chain of regex with acceptable peers").
  102variable(goal,          prolog,  get,  "Goal to use for processing").
  103variable(out_stream,    prolog,  get,  "Stream for output").
  104variable(peer,          name,    get,  "Peer connection (host only)").
  105variable(request,       string*, get,  "Data for first line").
  106variable(data,          string*, get,  "Data for POST request").
  107variable(chunk_data,    string*, get,  "Collect chunked input").
  108variable(mode,
  109         {request,header,post_content_length,chunked} := request,
  110                                 get,  "Mode of operation").
  111
  112:- pce_global(@http_end_header_regex,
  113              new(regex('\n\r?\n\r?'))).
  114:- pce_global(@http_end_line_regex,
  115              new(regex('\n\r?'))).
  116:- pce_global(@http_has_header_regex,
  117              new(regex('[^\n]*HTTP/'))).
  118
  119initialise(S, Goal:prolog, Port:[int]) :->
  120    default(Port, 0, ThePort),      % anonymous
  121    send_super(S, initialise, ThePort),
  122    send(S, slot, goal, Goal),
  123    send(S, record_separator, @http_end_line_regex),
  124    send(S, input_message, message(@receiver, input, @arg1)),
  125    send(S, accept_message, message(@arg1, accepted)),
  126    send(S, listen, reuse := @on),
  127    send(@http_servers, append, S).
  128
  129unlink(S) :->
  130    send(@http_servers, delete_all, S),
  131    send_super(S, unlink).
  132
  133:- pce_group(connection).
  134
  135accepted(S) :->
  136    "A new connection is established on this socket"::
  137    (   pce_catch_error(_, get(S, peer_name, tuple(Peer, _Port)))
  138    ->  send(S, slot, peer, Peer),
  139        send(S, authorise),
  140        debug(connection, 'New connection from ~w', [Peer]),
  141        pce_open(S, append, Fd),
  142        send(S, slot, out_stream, Fd)
  143    ;   debug(connection, 'Cannot get peer: closing.', []),
  144        free(S)
  145    ).
  146
  147authorise(S) :->
  148    "See whether we will proceeed with this connection"::
  149    get(S, allowed_hosts, Allowed),
  150    (   Allowed == @nil
  151    ->  true
  152    ;   get(S, peer, Peer),
  153        (   get(Allowed, find,
  154                message(@arg1, match, Peer),
  155                _)
  156        ->  true
  157        ;   debug(connection, 'Refused connection from ~w', [Peer]),
  158            free(S),
  159            fail
  160        )
  161    ).
  162
  163unlink(S) :->
  164    (   debugging(connection)
  165    ->  get(S, peer, Peer),
  166        debug(connection, 'Closed connection from ~w', [Peer])
  167    ;   true
  168    ),
  169    (   get(S, slot, out_stream, Fd),
  170        Fd \== @nil
  171    ->  catch(close(Fd), _, true)
  172    ;   true
  173    ),
  174    send_super(S, unlink).
  175
  176:- pce_group(request).
  177
  178/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  179->input collects input from  the  stream   until  an  entire  request is
  180complete. A request consists of one of the following:
  181
  182        <Request>       ::= <Action> <Path>\n
  183                          | <Action> <Path> HTTP/<Version>\n
  184                            <Header>
  185                            <Post Data>?
  186- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  187
  188input(S, Input:string) :->
  189    "Process input.  The argument is the header"::
  190    get(S, mode, Mode),
  191    (   debugging(input)
  192    ->  send(@pce, format, 'GOT (mode %s): "%s"\n', Mode, Input)
  193    ;   true
  194    ),
  195    (   Mode == request             % got first line
  196    ->  (   send(@http_has_header_regex, match, Input)
  197        ->  send(S, slot, request, Input),
  198            send(S, slot, mode, header),
  199            send(S, record_separator, @http_end_header_regex)
  200        ;   send(S, dispatch, Input)
  201        )
  202    ;   Mode == header
  203    ->  send(Input, prepend, S?request),
  204        send(S, slot, request, @nil),
  205        (   send(S, collect_post_data, Input)
  206        ->  true
  207        ;   send(S, dispatch, Input)
  208        )
  209    ;   Mode == post_content_length
  210    ->  send(S, slot, mode, request),
  211        send(S, record_separator, @http_end_line_regex),
  212        get(S, data, Header),
  213        send(Header, append, Input),
  214        send(Header, lock_object, @on),
  215        send(S, slot, data, @nil),
  216        send(S, dispatch, Header),
  217        send(Header, lock_object, @off)
  218    ;   Mode == chunked
  219    ->  get(S, chunk_data, ChunkData),
  220        (   get(S, record_separator, Bytes),
  221            integer(Bytes)
  222        ->  send(ChunkData, append, Input),
  223            send(S, record_separator, '\n')
  224        ;   send(Input, prepend, '0x'),
  225            get(Input, value, HexAtom),
  226            term_to_atom(Bytes, HexAtom),
  227            (   Bytes == 0
  228            ->  get(S, data, Header),
  229                get(ChunkData, size, ContentLength),
  230                send(@http_chunked_regex, search, Header),
  231                send(@http_chunked_regex, register_value, 0, Header,
  232                     string('Content-Length: %d', ContentLength)),
  233                send(Header, append, ChunkData),
  234                send(S, slot, chunk_data, @nil),
  235                send(S, slot, mode, request),
  236                send(S, record_separator, @http_end_line_regex),
  237                send(S, dispatch, Header)
  238            ;   send(S, record_separator, Bytes)
  239            )
  240        )
  241    ).
  242
  243
  244dispatch(S, Input:string) :->
  245    "Hand complete input for dispatching"::
  246    (   debugging(dispatch)
  247    ->  send(@pce, write_ln, Input)
  248    ;   true
  249    ),
  250    pce_open(Input, read, In),
  251    get(S, goal, Goal),
  252    get(S, out_stream, Out),
  253    (   catch(http_wrapper(Goal, In, Out, Close, []),
  254              E, wrapper_error(E))
  255    ->  close(In),
  256        (   downcase_atom(Close, 'keep-alive')
  257        ->  send(S, slot, mode, request), % prepare for next
  258            send(S, record_separator, @http_end_line_regex),
  259            send(S, slot, data, @nil)
  260        ;   free(S)
  261        )
  262    ;   close(In),                  % exception or failure
  263        free(S)
  264    ).
  265
  266wrapper_error(Error) :-
  267    (   debugging(connection)
  268    ->  print_message(error, Error)
  269    ;   true
  270    ),
  271    fail.
  272
  273:- pce_group(post).
  274
  275
  276:- pce_global(@http_content_length_regex,
  277              new(regex('^Content-Length:[[:blank:]]*([0-9]+)', @off))).
  278:- pce_global(@http_chunked_regex,
  279              new(regex('^Transfer-encoding:[[:blank:]]*chunked', @off))).
  280
  281
  282collect_post_data(S, Header:string) :->
  283    (   send(@http_content_length_regex, search, Header)
  284    ->  get(@http_content_length_regex, register_value, Header,
  285            1, int, Len),
  286        debug(dispatch, '[POST] Content-length: ~w~n', [Len]),
  287        send(S, slot, mode, post_content_length),
  288        send(S, slot, data, Header),
  289        send(S, record_separator, Len)
  290    ;   send(@http_chunked_regex, search, Header)
  291    ->  send(S, slot, mode, chunked),
  292        send(S, slot, chunk_data, new(string)),
  293        send(S, record_separator, '\n')
  294    ).
  295
  296:- pce_end_class(interactive_httpd)