1/*  Part of XPCE --- The SWI-Prolog GUI toolkit
    2
    3    Author:        Jan Wielemaker and Anjo Anjewierden
    4    E-mail:        jan@swi.psy.uva.nl
    5    WWW:           http://www.swi.psy.uva.nl/projects/xpce/
    6    Copyright (c)  2000-2011, 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(pce_http_client, []).   36:- use_module(library(pce)).   37:- use_module(library(url)).   38:- use_module(library(option)).   39
   40/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
   41This module defines the clas http_client, a subclass of class socket for
   42fetching data from HTTP servers (aka `web-servers').
   43
   44It can deal with two HTTP operations
   45
   46        # GET
   47        Get data from an URL
   48
   49        # HEAD
   50        Get only the header from an URL.
   51
   52The GET operation is implemented by ->fetch_data:
   53
   54http_client ->fetch_data: Into:object, Confirm:[code]*, Location:[string]
   55        Fetches data from the server.  Data is stored into `Into' in
   56        chunks using `->append: string' to this object.
   57
   58        If confirm is not @nil, ->fetch_data returns after connecting
   59        and sending the request to the server.  On completion, the
   60        Confirm message is executed with
   61
   62                @arg1   The http_client object
   63                @arg2   The `Into' object
   64
   65        If `Confirm' is @nil, ->fetch_data blocks until all data has
   66        been received.
   67
   68        In addition to returning the data, the header of the HTTP reply
   69        is attached to the data in a sheet using the attribute `http_header'.
   70        Field-names are in lowercase.  The date and last-modified fields
   71        appear as XPCE date objects and the content-length as an XPCE
   72        integer.
   73
   74http_client <-data --> String
   75        Simple interface to get data.  Returns a string with http_header
   76        attribute sheet (see above).  Blocks until all data has been received.
   77
   78http_client <-header --> Sheet
   79        Yield a sheet containing the header only the header data for the
   80        URL.
   81- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
   82
   83:- pce_begin_class(http_client, socket,
   84                   "Client socket for HTTP Protocol").
   85
   86:- pce_global(@nl_regex, new(regex('\n'))).
   87:- pce_global(@http_reply_regex,
   88              new(regex('HTTP/([0-9]\\.[0-9])\\s*(\\d+)\\s*(\\w*)'))).
   89:- pce_global(@http_field_regex,
   90              new(regex('([a-zA-Z0-9-]+):\\s*(.*)$'))).
   91:- pce_global(@http_empty_line_regex,
   92              new(regex('\\s*\r?$'))).
   93
   94:- initialization
   95   new(_, error(http_bad_header,
   96            '%O: Bad header line: %s',
   97            warning)),
   98   new(_, error(url_bad_protocol,
   99            '%O: Can only handle %s URLs',
  100            error)),
  101   new(_, error(url_bad_syntax,
  102            '%O: Not a legal URL: %s')).  103
  104variable(host,         name,           get,  "Host-name of URL").
  105variable(location,     string,         get,  "Location on server").
  106variable(message,      code*,          both, "Message send on completion").
  107variable(data_object,  object*,        get,  "Object holding data").
  108variable(received,     int*,           get,  "Data received").
  109variable(remaining,    int*,           get,  "Remaining data").
  110variable(request,      {header,data}*, get,  "Last request").
  111variable(req_status,   name*,          get,  "Progress").
  112variable(http_version, name,           both, "Used version (1.0/1.1)").
  113variable(user_agent,   name,           both, "Provided User-Agent").
  114variable(verbose,      {silent,connect,transfer} := connect,
  115                                       both, "Verbosity").
  116
  117initialise(S, URL:prolog) :->
  118    "Create from URL or parsed URL"::
  119    (   atomic(URL)
  120    ->  (   parse_url(URL, Parts)
  121        ->  true
  122        ;   send(S, error, url_bad_syntax, URL),
  123            fail
  124        )
  125    ;   Parts = URL
  126    ),
  127    (   memberchk(protocol(http), Parts)
  128    ->  true
  129    ;   send(S, error, url_bad_protocol, 'HTTP'),
  130        fail
  131    ),
  132    option(host(Host), Parts),
  133    option(port(Port), Parts, 80),
  134    http_location(Parts, Location),
  135    send(S, slot, host, Host),
  136    send(S, slot, location, Location),
  137    send(S, slot, http_version, '1.0'),
  138    send(S, slot, user_agent, 'XPCE/SWI-Prolog'),
  139    send_super(S, initialise, tuple(Host, Port)).
  140
  141:- pce_group(feedback).
  142
  143req_status(S, Status:{connecting,connected,header,data,complete}) :->
  144    "Indicate status changes"::
  145    send(S, slot, req_status, Status),
  146    (   get(S, verbose, silent)
  147    ->  true
  148    ;   message(Status, S, Message),
  149        ignore(send(S, Message))
  150    ).
  151
  152message(connecting, S, report(progress, 'Connecting %s', Host)) :-
  153    get(S, host, Host).
  154message(connected, _, report(progress, 'Connected')).
  155message(header,    _, report(progress, 'Receiving header')).
  156message(data,      _, report(progress, 'Receiving data')).
  157message(complete,  _, report(done)).
  158
  159progress(S, Progress:int, What:{percent,bytes}) :->
  160    "Indicate progress"::
  161    (   get(S, verbose, transfer),
  162        send(S, report, progress, 'Received %d %s', Progress, What)
  163    ->  true
  164    ;   true
  165    ).
  166
  167:- pce_group(connect).
  168
  169connect(S) :->
  170    "Connect to <-host"::
  171    (   get(S, status, connected)
  172    ->  true
  173    ;   send(S, req_status, connecting),
  174        send_super(S, connect),
  175        send(S, req_status, connected)
  176    ).
  177
  178:- pce_group(fetch).
  179
  180fetch_data(S,
  181           Object:into=object,
  182           Confirm:confirm=[code]*,
  183           Location:location=[string]) :->
  184    "Fetch data from location into Object"::
  185    send(S, slot, data_object, Object),
  186    (   Confirm == @default
  187    ->  true
  188    ;   send(S, slot, message, Confirm)
  189    ),
  190    (   Location == @default
  191    ->  true
  192    ;   send(S, slot, location, Location)
  193    ),
  194    send(S, slot, request, data),
  195    send(S, send_header, 'GET'),
  196    (   get(S, message, Msg),
  197        Msg \== @nil
  198    ->  true
  199    ;   send(S, wait)
  200    ).
  201
  202header(S, Location:[string], Header:sheet) :<-
  203    "Fetch header data from location as a sheet"::
  204    new(Object, object),
  205    send(S, slot, data_object, Object),
  206    (   Location == @default
  207    ->  true
  208    ;   send(S, slot, location, Location)
  209    ),
  210    send(S, slot, request, header),
  211    send(S, send_header, 'HEAD'),
  212    send(S, wait),
  213    get(Object, http_header, Header),
  214    send(Header, lock_object, @on),
  215    send(Object, delete_attribute, http_header),
  216    get(Header, unlock, _).
  217
  218data(S, Data:string) :<-
  219    "Fetch data from location as string"::
  220    new(TB, text_buffer),
  221    send(TB, undo_buffer_size, 0),
  222    send(S, fetch_data, TB),
  223    get(TB, contents, Data),
  224    get(TB, http_header, Header),
  225    send(Data, attribute, http_header, Header),
  226    free(TB).
  227
  228:- pce_group(internal).
  229
  230send_header(S, Action:name) :->
  231    "Send request header to HTTP server"::
  232    get(S, host, Host),
  233    send(S, slot, received, 0),
  234    send(S, prepare_header),
  235    send(S, slot, req_status, @nil),
  236    send(S, connect),
  237    get(S, http_version, Version),
  238    get(S, user_agent, Agent),
  239    get(S, location, Location),
  240    send(S, format, '%s %s HTTP/%s\r\n', Action, Location, Version),
  241    send(S, format, 'Host: %s\r\n', Host),
  242    send(S, format, 'User-Agent: %s\r\n', Agent),
  243    send(S, format, '\r\n').
  244
  245wait(S) :->
  246    "Wait for completion"::
  247    repeat,
  248    (   get(S, req_status, complete)
  249    ->  !
  250    ;   send(@display, dispatch),
  251        fail
  252    ).
  253
  254prepare_header(S) :->
  255    "Prepare for receiving header info"::
  256    send(S, record_separator, @nl_regex),
  257    send(S, input_message, message(S, header_line, @arg1)),
  258    send(S?data_object, attribute, http_header, new(sheet)).
  259
  260header_line(S, Line:string) :->
  261    "Handle the header lines as they come in"::
  262    (   send(@http_field_regex, match, Line)
  263    ->  get(@http_field_regex, register_value, Line, 1, name, FieldName0),
  264        get(FieldName0, downcase, FieldName),
  265        get(@http_field_regex, register_value, Line, 2, string, Value),
  266        send(Value, strip),
  267        field_type(FieldName, Type),
  268        get(@pce, convert, Value, Type, FieldValue),
  269        get(S, data_object, DataObject),
  270        send(DataObject?http_header, value, FieldName, FieldValue)
  271    ;   send(@http_reply_regex, match, Line)
  272    ->  get(S, data_object, DataObject),
  273        get(@http_reply_regex, register_value, Line, 2, int, ReplyStatus),
  274        send(DataObject?http_header, value, status, ReplyStatus),
  275        send(S, req_status, header)
  276    ;   send(@http_empty_line_regex, match, Line)
  277    ->  send(S, prepare_data)
  278    ;   send(S, error, http_bad_header, Line)
  279    ).
  280
  281field_type('content-length', int).
  282field_type('date',           date).
  283field_type('last-modified',  date).
  284field_type(_,                name).
  285
  286prepare_data(S) :->
  287    "Header has been received, prepare for content"::
  288    (   get(S, request, header)
  289    ->  send(S, req_status, complete)
  290    ;   (   get(S, data_object, Object),
  291            get(Object?http_header, value, 'content-length', Length)
  292        ->  send(S, slot, remaining, Length)
  293        ;   send(S, slot, remaining, @nil)
  294        ),
  295        send(S, input_message, message(S, data_record, @arg1)),
  296        send(S, record_separator, @nil)
  297    ).
  298
  299data_record(S, Record:string) :->
  300    "Receive a data record"::
  301    get(S, data_object, Data),
  302    (   get(S, remaining, Rem),
  303        Rem \== @nil
  304    ->  get(Record, size, Read),
  305        NewRem is Rem - Read,
  306        get(Data?http_header, value, 'content-length', Len),
  307        Percent is ((Len-NewRem)*100)//Len,
  308        send(S, progress, Percent, percent),
  309        (   NewRem >= 0
  310        ->  send(Data, append, Record),
  311            send(S, slot, remaining, NewRem),
  312            (   NewRem == 0
  313            ->  send(S, complete)
  314            ;   true
  315            )
  316        ;   send(Record, truncate, Rem),
  317            send(Data, append, Record),
  318            send(S, complete)
  319        )
  320    ;   send(Data, append, Record),
  321        get(Record, size, Bytes),
  322        get(S, received, Rec0),
  323        Rec is Rec0 + Bytes,
  324        send(S, slot, received, Rec),
  325        send(S, progress, Rec, bytes)
  326    ).
  327
  328end_of_file(S) :->
  329    "Implicit completion"::
  330    send(S, close),
  331    (   get(S, req_status, complete)
  332    ->  true
  333    ;   send(S, complete)
  334    ).
  335
  336complete(S) :->
  337    "We received all data"::
  338    send(S, req_status, complete),
  339    (   get(S, message, Message),
  340        Message \== @nil
  341    ->  get(S, data_object, Data),
  342        send(Message, forward, S, Data)
  343    ;   send(S, req_status, complete)
  344    ).
  345
  346:- pce_end_class