1/*  Part of SWI-Prolog
    2
    3    Author:        Jan Wielemaker
    4    E-mail:        jan@swi-prolog.org
    5    WWW:           https://www.swi-prolog.org
    6    Copyright (c)  2025, SWI-Prolog Solutions b.v.
    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(json_rpc_server,
   36          [ (json_method)/1,                    % M1,M2,...
   37            json_rpc_dispatch/2,                % :Stream, +Options
   38            json_rpc_error/2,                   % +Code, +Message
   39            json_rpc_error/3,                   % +Code, +Message, +Data
   40
   41            op(1100, fx, json_method)
   42          ]).   43:- use_module(library(json_rpc_common)).   44:- autoload(library(json), [json_read_dict/3]).   45:- autoload(library(apply), [maplist/3, include/3]).   46:- autoload(library(error), [must_be/2]).   47:- autoload(library(json_schema), [json_compile_schema/3, json_check/3]).   48:- autoload(library(lists), [append/3]).   49:- autoload(library(prolog_code), [extend_goal/3]).   50:- use_module(library(debug), [debug/3, assertion/1]).   51
   52:- meta_predicate
   53    json_rpc_dispatch(:, +).   54
   55:- public
   56    json_rpc_dispatch_request/4.   % +M, +Stream, +Request, +Options
   57
   58/** <module> JSON RPC Server
   59
   60This module implements an JSON RPC server. It provides declarations that
   61bind Prolog predicates to JSON RPC methods and a dispatch loop that acts
   62on a bi-directional stream. This module assumes a two-directional stream
   63and provides json_rpc_dispatch/2 that  receiveds   JSON  messages on the
   64input side of this stream and sends the replies through the output. This
   65module does not implement obtaining such   a  stream. Obvious candidates
   66for obtaining a stream are:
   67
   68  - Using standard I/O to a child process.  See process_create/3.
   69  - Using sockets.  See library(socket).  Using the SSL package this
   70    also provides secure sockets.
   71  - Using the HTTP package to extablish a _web socket_.
   72
   73This library defines json_method/1 for declaring  predicates to act as a
   74JSON method. The  declaration  accepts   a  JSON  Schema  specification,
   75represented as a SWI-Prolog dict to specify the input parameters as well
   76as the output.
   77
   78@see [JSON-RPC](https://www.jsonrpc.org/specification)
   79*/
   80
   81                /*******************************
   82                *         DECLARATIONS         *
   83                *******************************/
   84
   85%!  json_method(+Methods)
   86%
   87%   Methods is a comma-list of JSON RPC method declarations.   Each
   88%   declaration takes one of the forms below:
   89%
   90%      - Callable:Reply
   91%        Here, Callable is a Prolog callable term whose name and number
   92%        of argument match a predicate in this module.  The arguments
   93%        are JSON Schema types and Reply is a JSON Schema type.
   94%      - Callable
   95%        Callable is as above, but there is no return value.  This
   96%        implements JSON RPC _notifications_, i.e., asynchronously
   97%        processed messages for which we do not wait for a reply.
   98%
   99%   For example:
  100%
  101%   ```
  102%   :- json_method
  103%       subtract(#{type:number}, #{type:number}): #{type:number}.
  104%
  105%   subtract(A, B, R) :- R is A-B.
  106%   ```
  107%
  108%   Methods with _named arguments_ can  be   implemented  using a single
  109%   argument that is an object with   specified properties. For example,
  110%   the program below implements a  depositing   to  a bank account. The
  111%   method takes an `account` and `amount` parameter and returns the new
  112%   balance. The json_rpc_error/2 throws a JSON RPC _application error_.
  113%
  114%   ```
  115%   :- json_method
  116%       deposit(#{ properties:
  117%                  #{ account: #{type:string},
  118%                     amount:  #{type:number}
  119%                   }}): #{type:number},
  120%
  121%   deposit(Request, Reply),
  122%       #{account: Account, amount: Amount} :< Request =>
  123%       transaction((   retract(account(Account, Old))
  124%                   ->  New is Old+Amount,
  125%                       asserta(account(Account, New))
  126%                   ;   json_rpc_error(2, "Account does not exist")
  127%                   )),
  128%       Reply = New.
  129%   ```
  130
  131json_method(Methods) :-
  132    throw(error(context_error(nodirective, json_method(Methods)), _)).
  133
  134compile_methods((A,B)) ==>
  135    compile_methods(A),
  136    compile_methods(B).
  137compile_methods(M:Reply), callable(M) ==>
  138    { M =.. [Name|Args],
  139      argv_type(Args, Type),
  140      arg_type(Reply, RType)
  141    },
  142    [ '$json_method'(Name, Type, RType) ].
  143compile_methods(M), callable(M) ==>
  144    { M =.. [Name|Args],
  145      argv_type(Args, Type)
  146    },
  147    [ '$json_method'(Name, Type) ].
  148
  149argv_type([Named], QType), is_dict(Named) =>
  150    arg_type(Named.put(type, "object"), Type),
  151    QType = named(Type).
  152argv_type([Args], Type), is_list(Args) =>
  153    maplist(arg_type, Args, Types),
  154    Type = positional(Types).
  155argv_type(Args, Type) =>
  156    maplist(arg_type, Args, Types),
  157    Type = positional(Types).
  158
  159arg_type(Schema, Type) =>
  160    json_compile_schema(Schema, Type, []).
  161
  162:- multifile system:term_expansion/2.  163
  164system:term_expansion((:- json_method(Methods)), Clauses) :-
  165    \+ current_prolog_flag(xref, true),
  166    phrase(compile_methods(Methods), Clauses0),
  167    sort(Clauses0, Clauses).     % Avoid the need for discontiguous
  168
  169
  170                /*******************************
  171                *         DISPATCHING          *
  172                *******************************/
  173
  174%!  json_rpc_dispatch(:Stream, +Options) is det.
  175%
  176%   Run the JSON RPC dispatch  loop  until   end  of  file is reached on
  177%   Stream.
  178%
  179%   @arg Stream is stream pair (see stream_pair/2). Normally, the stream
  180%   should use `utf8` encoding. If the  stream   is  a binary stream, it
  181%   will be processed as if `utf8` encoding is  enabled. If it is a text
  182%   stream the encoding of the stream is respected.
  183
  184json_rpc_dispatch(M:Stream, Options) :-
  185    json_rpc_dispatch_1(M, Stream, EOF, Options),
  186    (   EOF == true
  187    ->  true
  188    ;   json_rpc_dispatch(M:Stream, Options)
  189    ).
  190
  191:- det(json_rpc_dispatch_1/4).  192json_rpc_dispatch_1(M, Stream, EOF, Options) :-
  193    Error = error(Formal,_),
  194    catch(json_read_dict(Stream, Request,
  195                         [ end_of_file(end_of_file(true))
  196                         | Options
  197                         ]),
  198          Error,
  199          true),
  200    debug(json_rpc(server), 'Request: ~p', [Request]),
  201    (   Request == end_of_file(true)
  202    ->  EOF = true
  203    ;   var(Formal)
  204    ->  json_rpc_dispatch_request(M, Stream, Request, Options)
  205    ;   print_message(error, Error)
  206    ).
  207
  208
  209%!  json_rpc_dispatch_request(+Module, +Stream, +Request, +Options)
  210%
  211%   Handle a request that has been read  from Stream, possibly sending a
  212%   reply to Stream.
  213
  214:- meta_predicate
  215    with_stream(+, 0).  216
  217json_rpc_dispatch_request(M, Stream, Requests, Options) :-
  218    is_list(Requests),
  219    !,                                          % batch processing
  220    with_stream(Stream,
  221                maplist(json_rpc_result_r(M, Options),
  222                        Requests, AllResults)),
  223    include(nonvar, AllResults, Results),
  224    json_rpc_reply(Stream, Results, Options).
  225json_rpc_dispatch_request(M, Stream, Request, Options) :-
  226    with_stream(Stream, json_rpc_result(M, Request, Result, Options)),
  227    json_rpc_reply(Stream, Result, Options).
  228
  229with_stream(Stream, Goal) :-
  230    setup_call_cleanup(
  231        b_setval(json_rpc_stream, Stream),
  232        Goal,
  233        nb_delete(json_rpc_stream)).
  234
  235
  236%!  json_rpc_reply(+Stream, +Result, +Options) is det.
  237
  238json_rpc_reply(Stream, Result, Options),
  239    is_dict(Result),
  240    Id = Result.get(id) =>
  241    debug(json_rpc(server), 'Replying ~p for request ~p', [Result,Id]),
  242    json_rpc_send(Stream, Result, Options).
  243json_rpc_reply(Stream, Results, Options), is_list(Results) =>
  244    debug(json_rpc(server), 'Replying batch results: ~p', [Results]),
  245    json_rpc_send(Stream, Results, Options).
  246json_rpc_reply(_Stream, Result, _Options), var(Result) =>
  247    true.                                       % notification
  248
  249json_rpc_result(M, Request, Result, Options) :-
  250    Error = error(_,_),
  251    catch(json_rpc_result_(M, Request, Result, Options),
  252          Error,
  253          json_exception_to_reply(Error, Request, Result)).
  254
  255json_rpc_result_r(M, Options, Request, Result) :-
  256    json_rpc_result(M, Request, Result, Options).
  257
  258:- det(json_rpc_result_/4).  259json_rpc_result_(M, Request, Result, Options) :-
  260    (   #{jsonrpc: "2.0", method:MethodS} :< Request
  261    ->  Params = Request.get(params, #{}),
  262        atom_string(Method, MethodS),
  263        (   Id = Request.get(id)
  264        ->  json_rpc_result(M, Method, Params, Id, Result, Options)
  265        ;   json_rpc_notify(M, Method, Params, Options)
  266        )
  267    ;   Id = Request.get(id)
  268    ->  Result = #{ jsonrpc: "2.0",
  269                    id: Id,
  270                    error: #{code: -32600,
  271                             message: "Invalid Request"}
  272                  }
  273    ;   print_message(error, json_rpc(invalid_request(Request)))
  274    ).
  275
  276json_rpc_result(M, Method, Params0, Id, Reply, Options) :-
  277    M:'$json_method'(Method, Types, RType),
  278    !,
  279    check_params(Params0, Types, Params, Options),
  280    debug(json_rpc(server), 'Calling method ~q for request ~p', [Method,Id]),
  281    run_method(M:Method, Params, Result),
  282    json_check_result(RType, Result, Options),
  283    Reply = #{ jsonrpc: "2.0",
  284               result: Result,
  285               id: Id
  286             }.
  287json_rpc_result(M, Method, Params0, Id, Reply, Options) :-
  288    M:'$json_method'(Method, Types),
  289    !,
  290    check_params(Params0, Types, Params, Options),
  291    debug(json_rpc(server), 'Calling method ~q for request ~p', [Method,Id]),
  292    (   apply(M:Method, Params)
  293    ->  Result = true
  294    ;   Result = false
  295    ),
  296    Reply = #{ jsonrpc: "2.0",
  297               result: Result,
  298               id: Id
  299             }.
  300json_rpc_result(_M, Method, _Params, Id, Reply, _Options) :-
  301    Reply = #{ jsonrpc: "2.0",
  302               id: Id,
  303               error: #{ code: -32601,
  304                         message: "Method not found",
  305                         data: Method
  306                       }
  307             }.
  308
  309%!  check_params(+CallParams, +ExpectedTypes, -Params, +Options) is det.
  310
  311check_params(#{}, positional([]), Params, _Options) :-
  312    !,
  313    Params = [].
  314check_params(Params, positional(Types), Params, Options) :-
  315    must_be(list, Params),
  316    maplist(json_check_param(Options), Types, Params),
  317    !.
  318check_params(Params, positional(Types), _Params, _Options) :-
  319    length(Types, Expected),
  320    length(Params, Found),
  321    format(string(Msg), "Expected ~d parameters, found ~d",
  322           [Expected, Found]),
  323    raise_param_error_data(Msg).
  324check_params(Param, named(Type), [Param], Options) :-
  325    json_check_param(Options, Type, Param).
  326
  327json_rpc_notify(M, Method, Params0, Options) :-
  328    M:'$json_method'(Method, Types),
  329    !,
  330    check_params(Params0, Types, Params, Options),
  331    apply(M:Method, Params).
  332json_rpc_notify(M, Method, Params0, Options) :-
  333    M:'$json_method'(Method, Types, _RType),
  334    !,
  335    check_params(Params0, Types, Params, Options),
  336    run_method(M:Method, Params, _Result).
  337json_rpc_notify(M, Method, Params0, _Options) :-
  338    print_message(warning,
  339                  json_rpc(not_implemented(M:Method, Params0))).
  340
  341%!  json_exception_to_reply(+Error, +Request, -Reply) is det.
  342%
  343%   Turn an exception into a JSON RPC   error document if Request has an
  344%   `id` field. Else it is  a  notification,   so  we  simply  print the
  345%   message in the server.
  346
  347:- det(json_exception_to_reply/3).  348json_exception_to_reply(error(json_rpc_error(Dict),_), Request, Reply),
  349    Id = Request.get(id) =>
  350    assertion(#{code:_, message:_} :< Dict),
  351    Reply = #{ jsonrpc: "2.0",
  352               id: Id,
  353               error: Dict
  354             }.
  355json_exception_to_reply(Error, Request, Reply),
  356    Id = Request.get(id) =>
  357    message_to_string(Error, Msg),
  358    Reply = #{ jsonrpc: "2.0",
  359               id: Id,
  360               error: #{ code: -32603,
  361                         message: "Internal error",
  362                         data: Msg}
  363             }.
  364json_exception_to_reply(Error, _Request, _Reply) =>
  365    print_message(error, Error).
  366
  367json_check_param(Option, Schema, Data) :-
  368    catch(json_check(Schema, Data, Option),
  369          Error,
  370          raise_param_error(Error)).
  371
  372raise_param_error(Error) :-
  373    message_to_string(Error, Msg),
  374    raise_param_error_data(Msg).
  375
  376raise_param_error_data(Msg) :-
  377    throw(error(json_rpc_error(#{ code: -32602,
  378                                  message: "Invalid params",
  379                                  data: Msg
  380                                }),
  381                _)).
  382
  383json_check_result(Schema, Data, Options) :-
  384    catch(json_check(Schema, Data, Options),
  385          Error,
  386          raise_result_error(Error)).
  387
  388raise_result_error(Error) :-
  389    message_to_string(Error, Msg),
  390    throw(error(json_rpc_error(#{ code: -32000,
  391                                  message: "Invalid return",
  392                                  data: Msg
  393                                }),
  394                _)).
  395
  396run_method(Method, Params, Result) :-
  397    append(Params, [Result], Args),
  398    Error = error(_,_),
  399    (   catch(apply(Method, Args), Error,
  400              raise_run_error(Error))
  401    ->  true
  402    ;   throw(error(json_rpc_error(#{ code: -32002,
  403                                      message: "Execution failed"
  404                                    }),
  405                    _))
  406    ).
  407
  408%!  raise_run_error(+Error)
  409%
  410%   Raised an error generated while running the   method. This can be an
  411%   application error raised  by  json_rpc_error/2,3   or  an  arbitrary
  412%   error.
  413
  414raise_run_error(Error),
  415    Error = error(json_rpc_error(_),_) =>
  416    throw(Error).
  417raise_run_error(Error) =>
  418    message_to_string(Error, Msg),
  419    throw(error(json_rpc_error(#{ code: -32001,
  420                                  message: "Execution error",
  421                                  data: Msg
  422                                }),
  423                _)).
  424
  425
  426%!  json_rpc_error(+Code, +Message).
  427%!  json_rpc_error(+Code, +Message, +Data).
  428%
  429%   Normally  called  from  a   method    implementation   to  raise  an
  430%   _application error_.
  431%
  432%   @arg Code is an integer.  The range -32768 to -32000 is reserved for
  433%   JSON RPC server errors.
  434%   @arg Message is a short string decribing the error
  435%   @arg Data is optional JSON data that provides context for the error.
  436%   @error json_rpc_error(Dict), where `Dict` contains the JSON RPC
  437%   defined fields `code`, `message` and optionally `data`.
  438
  439json_rpc_error(Code, Message) :-
  440    throw(error(json_rpc_error(#{ code: Code,
  441                                  message: Message
  442                                }),
  443                _)).
  444json_rpc_error(Code, Message, Data) :-
  445    throw(error(json_rpc_error(#{ code: Code,
  446                                  message: Message,
  447                                  data: Data
  448                                }),
  449                _)).
  450
  451
  452                /*******************************
  453                *              IDE             *
  454                *******************************/
  455
  456:- multifile
  457    prolog_colour:directive_colours/2,
  458    prolog:called_by/4.  459
  460prolog_colour:directive_colours(json_method(Decl),
  461                                expanded-[Colour]) :-
  462    decl_colours(Decl, Colour).
  463
  464decl_colours((A,B), Colour) =>
  465    Colour = punctuation-[CA, CB],
  466    decl_colours(A, CA),
  467    decl_colours(B, CB).
  468decl_colours(Head:_Type, Colour) =>
  469    extend_goal(Head, [_Ret], ExHead),
  470    Colour = punctuation-[body(ExHead),classify].
  471decl_colours(Head, Colour), callable(Head) =>
  472    Colour = body.
  473decl_colours(_Error, Colour) =>
  474    Colour = error(method_expected).
  475
  476prolog:called_by(json_method(Decl), _M, _C, Called) :-
  477    phrase(json_rpc_called_by(Decl), Called).
  478
  479json_rpc_called_by((A,B)) ==>
  480    json_rpc_called_by(A),
  481    json_rpc_called_by(B).
  482json_rpc_called_by(Head:_Type) ==>
  483    { extend_goal(Head, [_Ret], ExHead)
  484    },
  485    [ExHead].
  486json_rpc_called_by(Head), callable(Head) ==>
  487    [Head].
  488json_rpc_called_by(_) ==>
  489    []