1:- encoding(utf8).
    2:- module(
    3  rest_server,
    4  [
    5    conflicting_http_parameters/1, % +Keys
    6    data_uri/2,                    % +Segments, -Uri
    7    http_absolute_location/2,      % +Spec, -Path
    8    http_current_location/1,       % -Uri
    9    http_parameter_alternatives/2, % +Parameters, -Value
   10    http_parameter_conflict/2,     % +Parameter1, +Parameter2
   11    http_is_get/1,                 % +Method
   12    http_link_to_id/2,             % +HandleId, -Local
   13    http_media_types/2,            % +Request, -MediaTypes
   14    http_reply_json/1,             % +Json
   15    rest_media_type/2,             % +MediaTypes, :Goal_1
   16    rest_method/2,                 % +Request, :Goal_2
   17    rest_method/4,                 % +Request, +HandleId, :Plural_2, :Singular_3
   18    rest_options/1,                % +Methods
   19    rest_parameters/2              % +Request, +Parameters
   20  ]
   21).

   27:- use_module(library(apply)).   28:- use_module(library(error)).   29:- use_module(library(http/http_dispatch)).   30:- use_module(library(http/http_json)).   31:- use_module(library(http/http_parameters)).   32:- use_module(library(http/http_path)).   33:- use_module(library(http/http_server_files)).   34:- use_module(library(http/http_wrapper)).   35:- use_module(library(http/json)).   36:- use_module(library(lists)).   37:- use_module(library(ordsets)).   38:- use_module(library(pairs)).   39:- use_module(library(settings)).   40
   41:- use_module(library(pair_ext)).   42:- use_module(library(resource)).   43:- use_module(library(uri_ext)).   44
   45:- dynamic
   46    http:location/3.   47
   48:- multifile
   49    http:location/3.   50
   51http:location(css, root(css), []).
   52http:location(fonts, root(fonts), []).
   53http:location(html, root(html), []).
   54http:location(img, root(img), []).
   55http:location(js, root(js), []).
   56http:location(md, root(md), []).
   57http:location(pdf, root(pdf), []).
   58http:location(ttl, root(ttl), []).
   59http:location(yaml, root(yaml), []).
   60
   61:- http_handler(/, http_not_found_handler,
   62                [methods([get,head,options]),prefix,priority(-1)]).   63:- http_handler(css(.), serve_files_in_directory(css), [prefix]).   64:- http_handler(fonts(.), serve_files_in_directory(fonts), [prefix]).   65:- http_handler(html(.), serve_files_in_directory(html), [prefix]).   66:- http_handler(img(.), serve_files_in_directory(img), [prefix]).   67:- http_handler(js(.), serve_files_in_directory(js), [prefix]).   68:- http_handler(md(.), serve_files_in_directory(md), [prefix]).   69:- http_handler(pdf(.), serve_files_in_directory(pdf), [prefix]).   70:- http_handler(ttl(.), serve_files_in_directory(ttl), [prefix]).   71:- http_handler(yaml(.), serve_files_in_directory(yaml), [prefix]).   72
   73:- meta_predicate
   74    rest_media_type(+, 1),
   75    rest_method(+, 2),
   76    rest_method(+, +, 2, 3).   77
   78:- multifile
   79    error:has_type/2,
   80    html:page_exception/2,
   81    http:convert_parameter/3,
   82    http:error_status_message_hook/3,
   83    http:not_found_media_type/2,
   84    http:param/2.   85
   86error:has_type(or(Types), Term) :-
   87  member(Type, Types),
   88  error:has_type(Type, Term), !.
   89
   90http:convert_parameter(positive_integer, Atom, Integer) :-
   91  (   atom_number(Atom, Integer)
   92  ->  must_be(positive_integer, Integer)
   93  ;   instantiation_error(positive_integer)
   94  ).
   95
   96% GET,HEAD: application/json
   97http:not_found_media_type(Uri, media(application/json,_)) :-
   98  format(string(Msg), "😿 Path ‘~a’ does not exist on this server.", [Uri]),
   99  http_reply_json(_{message: Msg, status: 404}).
  100
  101:- setting(
  102     http:products,
  103     list(pair(string)),
  104     [],
  105     "The products that implement the server that creates HTTP replies."
  106   ).

 conflicting_http_parameters(+Keys:list(atom)) is det

  113conflicting_http_parameters(Keys) :-
  114  throw(error(conflicting_http_parameters(Keys))).

 data_uri(+Segments:list(atom), -Uri:atom) is det

  120data_uri(Segments, Uri) :-
  121  setting(http:public_scheme, Scheme),
  122  setting(http:public_host, Host),
  123  setting(http:public_port, Port),
  124  uri_comps(Uri, uri(Scheme,auth(_User,_Password,Host,Port),Segments,_,_)).

 http_absolute_location(+Spec, -Path:atom) is det

  130http_absolute_location(Spec, Path) :-
  131  http_absolute_location(Spec, Path, []).

 http_current_location(-Uri:atom) is det

  137http_current_location(Uri) :-
  138  http_current_request(Request),
  139  memberchk(path(Uri), Request).

 http_is_get(@Method:atom) is semidet

Succeeds for GET and HEAD requests. HEAD requests are handled just like GET requests. The SWI HTTP library deals with leaving out the body for HEAD requests.

  149http_is_get(get).
  150http_is_get(head).

 http_link_to_id(+HandleId, -Local) is det

  156http_link_to_id(HandleId, Local) :-
  157  http_link_to_id(HandleId, [], Local).

 http_media_types(+Request:compound, +MediaTypes:list(compound)) is det

  163% A sequence of Media Types (from most to least acceptable).
  164http_media_types(Request, MediaTypes) :-
  165  memberchk(accept(MediaTypes0), Request),
  166  clean_media_types(MediaTypes0, MediaTypes), !.
  167% Any Media Type is accepted (`*`).
  168http_media_types(_, [_]).
  169
  170clean_media_types(L1, L2) :-
  171  maplist(clean_media_type, L1, Pairs),
  172  sort(1, @>=, Pairs, Sorted),
  173  pairs_values(Sorted, L2).
  174
  175clean_media_type(
  176  media(Super/Sub,Params1,QValue,_),
  177  QValue-media(Super/Sub,Params2)
  178) :-
  179  maplist(clean_parameter, Params1, Params2).
  180
  181clean_parameter(charset=Value1, Value2) :- !,
  182  clean_charset(Value1, Value2).
  183clean_parameter(Param, Param).
  184
  185clean_charset('UTF-8', utf8) :- !.
  186clean_charset(Value, Value).

 http_not_found_handler(+Request:compound) is det

Default HTTP handler for replies with a 404 status code.

  194http_not_found_handler(Request) :-
  195  rest_method(Request, http_not_found_method(Request)).
  196
  197% GET,HEAD
  198http_not_found_method(Request, Method, MediaTypes) :-
  199  http_is_get(Method),
  200  memberchk(request_uri(Uri), Request),
  201  rest_media_type(MediaTypes, http:not_found_media_type(Uri)).

 http_parameter_alternatives(+Params:list(compound), -Value:term) is det

  207http_parameter_alternatives(Params, Value) :-
  208  convlist(http_parameter_value, Params, Pairs),
  209  pairs_keys_values(Pairs, Keys, Values1),
  210  (   list_to_ord_set(Values1, Values2),
  211      (Values2 = [Value] ; Values2 = [])
  212  ->  true
  213  ;   conflicting_http_parameters(Keys)
  214  ).
  215
  216http_parameter_value(Param, Key-Value) :-
  217  ground(Param),
  218  Param =.. [Key,Value].

 http_parameter_conflict(+Parameter1:compound, +Parameter2:compound) is det

  224http_parameter_conflict(Param1, Param2) :-
  225  ground([Param1,Param2]), !,
  226  Param1 =.. [Key1,_],
  227  Param2 =.. [Key2,_],
  228  throw(
  229    error(
  230      http_error(conflicting_parameters([Key1,Key2])),
  231      http_parameter_conflict/2
  232    )
  233  ).
  234http_parameter_conflict(_, _).

 http_reply_json(+Json) is det

  240http_reply_json(Json) :-
  241  format("Content-Type: application/json; charset=UTF-8\n\n"),
  242  json_write_dict(current_output, Json).

 rest_exception(+MediaTypes:list(compound), +Error:between(400,499)) is det

  248rest_exception(_, error(http_error(media_types_not_supported,MediaTypes),_Context)) :- !,
  249  media_types_not_supported_(MediaTypes).
  250rest_exception(MediaTypes, E) :-
  251  error_status_message(E, Status, Msg),
  252  member(MediaType, MediaTypes),
  253  rest_exception_media_type(MediaType, Status, Msg), !.
  254rest_exception(MediaTypes, _) :-
  255  media_types_not_supported_(MediaTypes).
  256
  257media_types_not_supported_(MediaTypes) :-
  258  format(
  259    string(Msg),
  260    "😿 None of the specified Media Types is supported: “~w”.",
  261    MediaTypes
  262  ),
  263  rest_exception_media_type(media(application/json,_), 406, Msg).
  264
  265% application/json
  266rest_exception_media_type(media(application/json,_), Status, Msg) :-
  267  reply_json_dict(_{message: Msg, status: Status}, [status(Status)]).
  268% text/html
  269rest_exception_media_type(media(text/html,_), Status, Msg) :-
  270  html:page_exception(Status, Msg).
  271
  272error_status_message(E, Status, Msg) :-
  273  http:error_status_message_hook(E, Status, Msg), !.
  274error_status_message(error(existence_error(Type,Term),_), 404, Msg) :- !,
  275  format(
  276    string(Msg),
  277    "😿 Your request is incorrect!  There is no resource denoted by term ‘~w’ of type ‘~w’.",
  278    [Term,Type]
  279  ).
  280error_status_message(error(http_error(conflicting_http_parameters(Keys)),_), 400, Msg) :- !,
  281  atomics_to_string(Keys, ", ", KeysLabel),
  282  format(
  283    string(Msg),
  284    "😿 Your request is incorrect!  You have specified the following conflicting HTTP parameters: ‘[~s]’.",
  285    [KeysLabel]
  286  ).
  287error_status_message(error(http_error(method_not_allowed,Method)), 405, Msg) :- !,
  288  format(
  289    string(Msg),
  290    "😿 HTTP method ‘~a’ is not allowed for this path.",
  291    [Method]
  292  ).
  293error_status_message(error(syntax_error(grammar(Language,Source)),_), 400, Msg) :- !,
  294  format(
  295    string(Msg),
  296    "😿 Could not parse the following according to the ~a grammar: “~a”",
  297    [Language,Source]
  298  ).
  299error_status_message(error(syntax_error(grammar(Language,Expr,Source)),_), 400, Msg) :- !,
  300  format(
  301    string(Msg),
  302    "😿 Could not parse the following as a ~a expression in the ~a grammar: “~a”",
  303    [Expr,Language,Source]
  304  ).
  305error_status_message(error(type_error(Type,Value),context(_,http_parameter(Key))), 400, Msg) :- !,
  306  format(
  307    string(Msg),
  308    "😿 Your request is incorrect!  You have specified the value ‘~w’ for HTTP parameter ‘~a’.  However, values for this parameter must be of type ‘~w’.",
  309    [Value,Key,Type]
  310  ).
  311error_status_message(E, 500, Msg) :-
  312  format(string(Msg), "😿 The following error occurred on the server: ‘~w’.", [E]).

 rest_media_type(+MediaTypes:list(compound), :Goal_1) is det

  318rest_media_type(MediaTypes, Goal_1) :-
  319  member(MediaType, MediaTypes),
  320  call(Goal_1, MediaType), !.
  321rest_media_type(MediaTypes, _) :-
  322  rest_exception(
  323    MediaTypes,
  324    error(http_error(media_types_not_supported,MediaTypes),http_server)
  325  ).

 rest_method(+Request:list(compound), :Goal_2) is det

 rest_method(+Request:list(compound), +HandleId, :Plural_2, :Singular_3) is det

  332rest_method(Request, Plural_2) :-
  333  rest_method(Request, _, Plural_2, _:_).
  334
  335
  336rest_method(Request, HandleId, Mod:Plural_2, Mod:Singular_3) :-
  337  memberchk(method(Method), Request),
  338  memberchk(path(Path), Request),
  339  Mod:http_current_handler(Path, _, Options),
  340  _{methods: Methods} :< Options,
  341  (   Method == options
  342  ->  rest_options(Methods)
  343  ;   % 405 Method Not Allowed
  344      \+ memberchk(Method, Methods)
  345  ->  http_media_types(Request, MediaTypes),
  346      rest_exception(MediaTypes, error(http_error(method_not_allowed,Method),_))
  347  ;   % `Method' is one of the accepted `Methods'.
  348      memberchk(request_uri(Uri), Request),
  349      % Remove the query and fragment components from the URI in order
  350      % to compare it to the current `HandleId'.
  351      uri_comps(Uri, uri(Scheme,Authority,Segments,_,_)),
  352      uri_comps(HandleUri, uri(Scheme,Authority,Segments,_,_)),
  353      format("Strict-Transport-Security: max-age=31536000; includeSubDomains\n"),
  354      http_media_types(Request, MediaTypes),
  355      catch(
  356        (   (var(HandleId) -> true ; http_link_to_id(HandleId, HandleUri))
  357        ->  call(Mod:Plural_2, Method, MediaTypes)
  358        ;   data_uri(Segments, Resource),
  359            call(Mod:Singular_3, Resource, Method, MediaTypes)
  360        ),
  361        Error,
  362        rest_exception(MediaTypes, Error)
  363      )
  364  ).

 rest_options(+Methods:list(atom)) is det

  370rest_options(Methods) :-
  371  format("Status: 204\n"),
  372  write_allow_header(Methods),
  373  write_server_header,
  374  nl.

 rest_parameters(+Request:compound, +Parameters:list(compound)) is det

  380rest_parameters(Request, Params) :-
  381  http_parameters(Request, Params, [attribute_declarations(http:param)]).

 write_allow_header(+Methods:list(atom)) is det

Allow = #method
method = token

  392write_allow_header([H|T]) :-
  393  format("Allow: ~a", [H]),
  394  maplist(write_sep_allow, T),
  395  nl.
  396
  397write_sep_allow(X) :-
  398  format(", ~a", [X]).

 write_server_header(+Products:list(pair(atom))) is det

Server = product *( RWS ( product | comment ) )
product = token ["/" product-version]
product-version = token

  410write_server_header :-
  411  setting(http:products, Products),
  412  write_products(Products).
  413
  414write_products([H|T]) :-
  415  format("Server: "),
  416  write_product(H),
  417  maplist(write_sep_product, T),
  418  nl.
  419
  420write_product(X-Y) :- !,
  421  format("~a/~a", [X,Y]).
  422write_product(X) :- !,
  423  format("~a", [X]).
  424
  425write_sep_product(X) :-
  426  format(" "),
  427  write_product(X)