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    default_json_content_type(Type),
  342    format('Content-type: ~w~n~n', [Type]),
  343    json_write(current_output, Term).
  344
  345reply_json(Dict, Options) :-
  346    is_dict(Dict),
  347    !,
  348    reply_json_dict(Dict, Options).
  349reply_json(Term, Options) :-
  350    reply_json2(Term, Options).
  351
  352%!  reply_json_dict(+JSONTerm) is det.
  353%!  reply_json_dict(+JSONTerm, +Options) is det.
  354%
  355%   As reply_json/1 and reply_json/2, but assumes the new dict based
  356%   data representation. Note that this is  the default if the outer
  357%   object is a dict. This predicate is   needed to serialize a list
  358%   of   objects   correctly   and     provides   consistency   with
  359%   http_read_json_dict/2 and friends.
  360
  361reply_json_dict(Dict) :-
  362    default_json_content_type(Type),
  363    format('Content-type: ~w~n~n', [Type]),
  364    json_write_dict(current_output, Dict).
  365
  366reply_json_dict(Dict, Options) :-
  367    merge_options([json_object(dict)], Options, Options1),
  368    reply_json2(Dict, Options1).
  369
  370reply_json2(Term, Options) :-
  371    default_json_content_type(DefType),
  372    select_option(content_type(Type), Options, Rest0, DefType),
  373    (   select_option(status(Code), Rest0, Rest)
  374    ->  format('Status: ~d~n', [Code])
  375    ;   Rest = Rest0
  376    ),
  377    format('Content-type: ~w~n~n', [Type]),
  378    json_write_to(current_output, Term, Rest).
  379
  380default_json_content_type('application/json; charset=UTF-8').
  381
  382
  383		 /*******************************
  384		 *       STATUS HANDLING	*
  385		 *******************************/
  386
  387:- multifile
  388    http:status_reply/3,
  389    http:serialize_reply/2.  390
  391http:serialize_reply(json(Term), body(application/json, utf8, Content)) :-
  392    with_output_to(string(Content),
  393                   json_write_dict(current_output, Term, [])).
  394
  395http:status_reply(Term, json(Reply), Options) :-
  396    prefer_json(Options.get(accept)),
  397    json_status_reply(Term, Lines, Extra),
  398    phrase(txt_message_lines(Lines), Codes),
  399    string_codes(Message, Codes),
  400    Reply = _{code:Options.code, message:Message}.put(Extra).
  401
  402txt_message_lines([]) -->
  403    [].
  404txt_message_lines([nl|T]) -->
  405    !,
  406    "\n",
  407    txt_message_lines(T).
  408txt_message_lines([flush]) -->
  409    !.
  410txt_message_lines([FmtArgs|T]) -->
  411    dcg_format(FmtArgs),
  412    txt_message_lines(T).
  413
  414dcg_format(Fmt-Args, List, Tail) :-
  415    !,
  416    format(codes(List,Tail), Fmt, Args).
  417dcg_format(ansi(_Style, Fmt,Args), List, Tail) :-
  418    !,
  419    format(codes(List,Tail), Fmt, Args).
  420dcg_format(url(Pos), List, Tail) :-
  421    !,
  422    dcg_url(Pos, List, Tail).
  423dcg_format(url(_URL, Label), List, Tail) :-
  424    !,
  425    format(codes(List,Tail), '~w', [Label]).
  426dcg_format(Fmt, List, Tail) :-
  427    format(codes(List,Tail), Fmt, []).
  428
  429dcg_url(File:Line:Column, List, Tail) :-
  430    !,
  431    format(codes(List,Tail), '~w:~d:~d', [File, Line, Column]).
  432dcg_url(File:Line, List, Tail) :-
  433    !,
  434    format(codes(List,Tail), '~w:~d', [File, Line]).
  435dcg_url(File, List, Tail) :-
  436    !,
  437    format(codes(List,Tail), '~w', [File]).
  438
  439
  440%!  prefer_json(+Accept)
  441%
  442%   True when the accept encoding prefers JSON.
  443
  444prefer_json(Accept) :-
  445    memberchk(media(application/json, _, JSONP,  []), Accept),
  446    (   member(media(text/html, _, HTMLP,  []), Accept)
  447    ->  JSONP > HTMLP
  448    ;   true
  449    ).
  450
  451%!  json_status_reply(+Term, -MsgLines, -ExtraJSON) is semidet.
  452
  453json_status_reply(created(Location),
  454                  [ 'Created: ~w'-[Location] ],
  455                  _{location:Location}).
  456json_status_reply(moved(Location),
  457                  [ 'Moved to: ~w'-[Location] ],
  458                  _{location:Location}).
  459json_status_reply(moved_temporary(Location),
  460                  [ 'Moved temporary to: ~w'-[Location] ],
  461                  _{location:Location}).
  462json_status_reply(see_other(Location),
  463                  [ 'See: ~w'-[Location] ],
  464                  _{location:Location}).
  465json_status_reply(bad_request(ErrorTerm), Lines, _{}) :-
  466    '$messages':translate_message(ErrorTerm, Lines, []).
  467json_status_reply(authorise(Method),
  468                  [ 'Authorization (~p) required'-[Method] ],
  469                  _{}).
  470json_status_reply(forbidden(Location),
  471                  [ 'You have no permission to access: ~w'-[Location] ],
  472                  _{location:Location}).
  473json_status_reply(not_found(Location),
  474                  [ 'Path not found: ~w'-[Location] ],
  475                  _{location:Location}).
  476json_status_reply(method_not_allowed(Method,Location),
  477                  [ 'Method not allowed: ~w'-[UMethod] ],
  478                  _{location:Location, method:UMethod}) :-
  479    upcase_atom(Method, UMethod).
  480json_status_reply(not_acceptable(Why),
  481                  [ 'Request is not acceptable: ~p'-[Why]
  482                  ],
  483                  _{}).
  484json_status_reply(server_error(ErrorTerm), Lines, _{}) :-
  485    '$messages':translate_message(ErrorTerm, Lines, []).
  486json_status_reply(service_unavailable(Why),
  487                  [ 'Service unavailable: ~p'-[Why]
  488                  ],
  489                  _{})