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)  2007-2018, 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_json,
   37          [ reply_json/1,               % +JSON
   38            reply_json/2,               % +JSON, Options
   39            reply_json_dict/1,          % +JSON
   40            reply_json_dict/2,          % +JSON, Options
   41            http_read_json/2,           % +Request, -JSON
   42            http_read_json/3,           % +Request, -JSON, +Options
   43            http_read_json_dict/2,      % +Request, -Dict
   44            http_read_json_dict/3,      % +Request, -Dict, +Options
   45
   46            is_json_content_type/1      % +HeaderValue
   47          ]).   48:- use_module(library(http/http_client)).   49:- use_module(library(http/http_header)).   50:- use_module(library(http/http_stream)).   51:- use_module(library(http/json)).   52:- use_module(library(option)).   53:- use_module(library(error)).   54:- use_module(library(lists)).   55:- use_module(library(memfile)).   56
   57:- multifile
   58    http_client:http_convert_data/4,
   59    http:post_data_hook/3,
   60    json_type/1.   61
   62:- public
   63    json_type/1.   64
   65:- predicate_options(http_read_json/3, 3,
   66                     [ content_type(any),
   67                       false(ground),
   68                       null(ground),
   69                       true(ground),
   70                       value_string_as(oneof([atom, string])),
   71                       json_object(oneof([term,dict]))
   72                     ]).   73:- predicate_options(reply_json/2, 2,
   74                     [ content_type(any),
   75                       status(integer),
   76                       json_object(oneof([term,dict])),
   77                       pass_to(json:json_write/3, 3)
   78                     ]).   79
   80
   81/** <module> HTTP JSON Plugin module
   82
   83Most   code   doesn't   need  to   use  this   directly;  instead   use
   84library(http/http_server),  which  combines   this  library  with   the
   85typical HTTP libraries that most servers need.
   86
   87This module adds hooks to several parts   of  the HTTP libraries, making
   88them JSON-aware.  Notably:
   89
   90  - Make http_read_data/3 convert `application/json` and
   91    `application/jsonrequest` content to a JSON term.
   92  - Cause http_open/3 to accept post(json(Term)) to issue a POST
   93    request with JSON content.
   94  - Provide HTTP server and client utility predicates for reading
   95    and replying JSON:
   96    - http_read_json/2
   97    - http_read_json/3
   98    - http_read_json_dict/2
   99    - http_read_json_dict/3
  100    - reply_json/1
  101    - reply_json/2
  102    - reply_json_dict/1
  103    - reply_json_dict/2
  104  - Reply to exceptions in the server using an JSON document rather
  105    then HTML if the =|Accept|= header prefers application/json over
  106    text/html.
  107
  108Typically JSON is used by Prolog HTTP  servers. This module supports two
  109JSON  representations:  the  classical  representation    and   the  new
  110representation supported by  the  SWI-Prolog   version  7  extended data
  111types. Below is a skeleton for  handling   a  JSON request, answering in
  112JSON using the classical interface.
  113
  114  ==
  115  handle(Request) :-
  116        http_read_json(Request, JSONIn),
  117        json_to_prolog(JSONIn, PrologIn),
  118        <compute>(PrologIn, PrologOut),         % application body
  119        prolog_to_json(PrologOut, JSONOut),
  120        reply_json(JSONOut).
  121  ==
  122
  123When using dicts, the conversion step is   generally  not needed and the
  124code becomes:
  125
  126  ==
  127  handle(Request) :-
  128        http_read_json_dict(Request, DictIn),
  129        <compute>(DictIn, DictOut),
  130        reply_json(DictOut).
  131  ==
  132
  133This module also integrates JSON support   into the http client provided
  134by http_client.pl. Posting a JSON query   and  processing the JSON reply
  135(or any other reply understood  by   http_read_data/3)  is  as simple as
  136below, where Term is a JSON term as described in json.pl and reply is of
  137the same format if the server replies with JSON.
  138
  139  ==
  140        ...,
  141        http_post(URL, json(Term), Reply, [])
  142  ==
  143
  144@see    JSON Requests are discussed in http://json.org/JSONRequest.html
  145@see    json.pl describes how JSON objects are represented in Prolog terms.
  146@see    json_convert.pl converts between more natural Prolog terms and json
  147terms.
  148*/
  149
  150%!  http_client:http_convert_data(+In, +Fields, -Data, +Options)
  151%
  152%   Hook implementation that supports  reading   JSON  documents. It
  153%   processes the following option:
  154%
  155%     * json_object(+As)
  156%     Where As is one of =term= or =dict=.  If the value is =dict=,
  157%     json_read_dict/3 is used.
  158
  159http_client:http_convert_data(In, Fields, Data, Options) :-
  160    memberchk(content_type(Type), Fields),
  161    is_json_content_type(Type),
  162    !,
  163    (   memberchk(content_length(Bytes), Fields)
  164    ->  setup_call_cleanup(
  165            ( stream_range_open(In, Range, [size(Bytes)]),
  166              set_stream(Range, encoding(utf8))
  167            ),
  168            json_read_to(Range, Data, Options),
  169            close(Range))
  170    ;   set_stream(In, encoding(utf8)),
  171        json_read_to(In, Data, Options)
  172    ).
  173
  174
  175%!  is_json_content_type(+ContentType) is semidet.
  176%
  177%   True  if  ContentType  is  a  header  value  (either  parsed  or  as
  178%   atom/string) that denotes a JSON value.
  179
  180is_json_content_type(String) :-
  181    http_parse_header_value(content_type, String,
  182                            media(Type, _Attributes)),
  183    json_type(Type),
  184    !.
  185
  186json_read_to(In, Data, Options) :-
  187    memberchk(json_object(dict), Options),
  188    !,
  189    json_read_dict(In, Data, Options).
  190json_read_to(In, Data, Options) :-
  191    json_read(In, Data, Options).
  192
  193%!  json_type(?MediaType) is semidet.
  194%
  195%   True if MediaType is a JSON media type. http_json:json_type/1 is
  196%   a  multifile  predicate  and  may   be  extended  to  facilitate
  197%   non-conforming clients.
  198%
  199%   @arg MediaType is a term `Type`/`SubType`, where both `Type` and
  200%   `SubType` are atoms.
  201
  202json_type(application/jsonrequest).
  203json_type(application/json).
  204
  205
  206%!  http:post_data_hook(+Data, +Out:stream, +HdrExtra) is semidet.
  207%
  208%   Hook implementation that allows   http_post_data/3  posting JSON
  209%   objects using one of the  forms   below.
  210%
  211%     ==
  212%     http_post(URL, json(Term), Reply, Options)
  213%     http_post(URL, json(Term, Options), Reply, Options)
  214%     ==
  215%
  216%   If Options are passed, these are handed to json_write/3. In
  217%   addition, this option is processed:
  218%
  219%     * json_object(As)
  220%     If As is =dict=, json_write_dict/3 is used to write the
  221%     output.  This is default if json(Dict) is passed.
  222%
  223%   @tbd avoid creation of intermediate data using chunked output.
  224
  225http:post_data_hook(json(Dict), Out, HdrExtra) :-
  226    is_dict(Dict),
  227    !,
  228    http:post_data_hook(json(Dict, [json_object(dict)]),
  229                        Out, HdrExtra).
  230http:post_data_hook(json(Term), Out, HdrExtra) :-
  231    http:post_data_hook(json(Term, []), Out, HdrExtra).
  232http:post_data_hook(json(Term, Options), Out, HdrExtra) :-
  233    option(content_type(Type), HdrExtra, 'application/json'),
  234    setup_call_cleanup(
  235        ( new_memory_file(MemFile),
  236          open_memory_file(MemFile, write, Handle)
  237        ),
  238        ( format(Handle, 'Content-type: ~w~n~n', [Type]),
  239          json_write_to(Handle, Term, Options)
  240        ),
  241        close(Handle)),
  242    setup_call_cleanup(
  243        open_memory_file(MemFile, read, RdHandle,
  244                         [ free_on_close(true)
  245                         ]),
  246        http_post_data(cgi_stream(RdHandle), Out, HdrExtra),
  247        close(RdHandle)).
  248
  249json_write_to(Out, Term, Options) :-
  250    memberchk(json_object(dict), Options),
  251    !,
  252    json_write_dict(Out, Term, Options).
  253json_write_to(Out, Term, Options) :-
  254    json_write(Out, Term, Options).
  255
  256
  257%!  http_read_json(+Request, -JSON) is det.
  258%!  http_read_json(+Request, -JSON, +Options) is det.
  259%
  260%   Extract JSON data posted  to  this   HTTP  request.  Options are
  261%   passed to json_read/3.  In addition, this option is processed:
  262%
  263%     * json_object(+As)
  264%     One of =term= (default) to generate a classical Prolog
  265%     term or =dict= to exploit the SWI-Prolog version 7 data type
  266%     extensions.  See json_read_dict/3.
  267%
  268%   @error  domain_error(mimetype, Found) if the mimetype is
  269%           not known (see json_type/1).
  270%   @error  domain_error(method, Method) if the request method is not
  271%           a =POST=, =PUT= or =PATCH=.
  272
  273http_read_json(Request, JSON) :-
  274    http_read_json(Request, JSON, []).
  275
  276http_read_json(Request, JSON, Options) :-
  277    select_option(content_type(Type), Options, Rest),
  278    !,
  279    delete(Request, content_type(_), Request2),
  280    request_to_json([content_type(Type)|Request2], JSON, Rest).
  281http_read_json(Request, JSON, Options) :-
  282    request_to_json(Request, JSON, Options).
  283
  284request_to_json(Request, JSON, Options) :-
  285    option(method(Method), Request),
  286    option(content_type(Type), Request),
  287    (   data_method(Method)
  288    ->  true
  289    ;   domain_error(method, Method)
  290    ),
  291    (   is_json_content_type(Type)
  292    ->  true
  293    ;   domain_error(mimetype, Type)
  294    ),
  295    http_read_data(Request, JSON, Options).
  296
  297data_method(post).
  298data_method(put).
  299data_method(patch).
  300
  301%!  http_read_json_dict(+Request, -Dict) is det.
  302%!  http_read_json_dict(+Request, -Dict, +Options) is det.
  303%
  304%   Similar to http_read_json/2,3, but by default uses the version 7
  305%   extended datatypes.
  306
  307http_read_json_dict(Request, Dict) :-
  308    http_read_json_dict(Request, Dict, []).
  309
  310http_read_json_dict(Request, Dict, Options) :-
  311    merge_options([json_object(dict)], Options, Options1),
  312    http_read_json(Request, Dict, Options1).
  313
  314%!  reply_json(+JSONTerm) is det.
  315%!  reply_json(+JSONTerm, +Options) is det.
  316%
  317%   Formulate a JSON  HTTP  reply.   See  json_write/2  for details.
  318%   The processed options are listed below.  Remaining options are
  319%   forwarded to json_write/3.
  320%
  321%       * content_type(+Type)
  322%       The default =|Content-type|= is =|application/json;
  323%       charset=UTF8|=. =|charset=UTF8|= should not be required
  324%       because JSON is defined to be UTF-8 encoded, but some
  325%       clients insist on it.
  326%
  327%       * status(+Code)
  328%       The default status is 200.  REST API functions may use
  329%       other values from the 2XX range, such as 201 (created).
  330%
  331%       * json_object(+As)
  332%       One of =term= (classical json representation) or =dict=
  333%       to use the new dict representation.  If omitted and Term
  334%       is a dict, =dict= is assumed.  SWI-Prolog Version 7.
  335
  336reply_json(Dict) :-
  337    is_dict(Dict),
  338    !,
  339    reply_json_dict(Dict).
  340reply_json(Term) :-
  341    format('Content-type: application/json; charset=UTF-8~n~n'),
  342    json_write(current_output, Term).
  343
  344reply_json(Dict, Options) :-
  345    is_dict(Dict),
  346    !,
  347    reply_json_dict(Dict, Options).
  348reply_json(Term, Options) :-
  349    reply_json2(Term, Options).
  350
  351%!  reply_json_dict(+JSONTerm) is det.
  352%!  reply_json_dict(+JSONTerm, +Options) is det.
  353%
  354%   As reply_json/1 and reply_json/2, but assumes the new dict based
  355%   data representation. Note that this is  the default if the outer
  356%   object is a dict. This predicate is   needed to serialize a list
  357%   of   objects   correctly   and     provides   consistency   with
  358%   http_read_json_dict/2 and friends.
  359
  360reply_json_dict(Dict) :-
  361    format('Content-type: application/json; charset=UTF-8~n~n'),
  362    json_write_dict(current_output, Dict).
  363
  364reply_json_dict(Dict, Options) :-
  365    merge_options([json_object(dict)], Options, Options1),
  366    reply_json2(Dict, Options1).
  367
  368reply_json2(Term, Options) :-
  369    select_option(content_type(Type), Options, Rest0, 'application/json'),
  370    (   select_option(status(Code), Rest0, Rest)
  371    ->  format('Status: ~d~n', [Code])
  372    ;   Rest = Rest0
  373    ),
  374    format('Content-type: ~w~n~n', [Type]),
  375    json_write_to(current_output, Term, Rest).
  376
  377
  378		 /*******************************
  379		 *       STATUS HANDLING	*
  380		 *******************************/
  381
  382:- multifile
  383    http:status_reply/3,
  384    http:serialize_reply/2.  385
  386http:serialize_reply(json(Term), body(application/json, utf8, Content)) :-
  387    with_output_to(string(Content),
  388                   json_write_dict(current_output, Term, [])).
  389
  390http:status_reply(Term, json(Reply), Options) :-
  391    prefer_json(Options.get(accept)),
  392    json_status_reply(Term, Lines, Extra),
  393    phrase(txt_message_lines(Lines), Codes),
  394    string_codes(Message, Codes),
  395    Reply = _{code:Options.code, message:Message}.put(Extra).
  396
  397txt_message_lines([]) -->
  398    [].
  399txt_message_lines([nl|T]) -->
  400    !,
  401    "\n",
  402    txt_message_lines(T).
  403txt_message_lines([flush]) -->
  404    !.
  405txt_message_lines([FmtArgs|T]) -->
  406    dcg_format(FmtArgs),
  407    txt_message_lines(T).
  408
  409dcg_format(Fmt-Args, List, Tail) :-
  410    !,
  411    format(codes(List,Tail), Fmt, Args).
  412dcg_format(ansi(_Style, Fmt,Args), List, Tail) :-
  413    !,
  414    format(codes(List,Tail), Fmt, Args).
  415dcg_format(url(Pos), List, Tail) :-
  416    !,
  417    dcg_url(Pos, List, Tail).
  418dcg_format(url(_URL, Label), List, Tail) :-
  419    !,
  420    format(codes(List,Tail), '~w', [Label]).
  421dcg_format(Fmt, List, Tail) :-
  422    format(codes(List,Tail), Fmt, []).
  423
  424dcg_url(File:Line:Column, List, Tail) :-
  425    !,
  426    format(codes(List,Tail), '~w:~d:~d', [File, Line, Column]).
  427dcg_url(File:Line, List, Tail) :-
  428    !,
  429    format(codes(List,Tail), '~w:~d', [File, Line]).
  430dcg_url(File, List, Tail) :-
  431    !,
  432    format(codes(List,Tail), '~w', [File]).
  433
  434
  435%!  prefer_json(+Accept)
  436%
  437%   True when the accept encoding prefers JSON.
  438
  439prefer_json(Accept) :-
  440    memberchk(media(application/json, _, JSONP,  []), Accept),
  441    (   member(media(text/html, _, HTMLP,  []), Accept)
  442    ->  JSONP > HTMLP
  443    ;   true
  444    ).
  445
  446%!  json_status_reply(+Term, -MsgLines, -ExtraJSON) is semidet.
  447
  448json_status_reply(created(Location),
  449                  [ 'Created: ~w'-[Location] ],
  450                  _{location:Location}).
  451json_status_reply(moved(Location),
  452                  [ 'Moved to: ~w'-[Location] ],
  453                  _{location:Location}).
  454json_status_reply(moved_temporary(Location),
  455                  [ 'Moved temporary to: ~w'-[Location] ],
  456                  _{location:Location}).
  457json_status_reply(see_other(Location),
  458                  [ 'See: ~w'-[Location] ],
  459                  _{location:Location}).
  460json_status_reply(bad_request(ErrorTerm), Lines, _{}) :-
  461    '$messages':translate_message(ErrorTerm, Lines, []).
  462json_status_reply(authorise(Method),
  463                  [ 'Authorization (~p) required'-[Method] ],
  464                  _{}).
  465json_status_reply(forbidden(Location),
  466                  [ 'You have no permission to access: ~w'-[Location] ],
  467                  _{location:Location}).
  468json_status_reply(not_found(Location),
  469                  [ 'Path not found: ~w'-[Location] ],
  470                  _{location:Location}).
  471json_status_reply(method_not_allowed(Method,Location),
  472                  [ 'Method not allowed: ~w'-[UMethod] ],
  473                  _{location:Location, method:UMethod}) :-
  474    upcase_atom(Method, UMethod).
  475json_status_reply(not_acceptable(Why),
  476                  [ 'Request is not acceptable: ~p'-[Why]
  477                  ],
  478                  _{}).
  479json_status_reply(server_error(ErrorTerm), Lines, _{}) :-
  480    '$messages':translate_message(ErrorTerm, Lines, []).
  481json_status_reply(service_unavailable(Why),
  482                  [ 'Service unavailable: ~p'-[Why]
  483                  ],
  484                  _{})