35
36:- module(http_dispatch,
37 [ http_dispatch/1, 38 http_handler/3, 39 http_delete_handler/1, 40 http_reply_file/3, 41 http_redirect/3, 42 http_404/2, 43 http_switch_protocol/2, 44 http_current_handler/2, 45 http_current_handler/3, 46 http_location_by_id/2, 47 http_link_to_id/3, 48 http_reload_with_parameters/3, 49 http_safe_file/2 50 ]).
51:- use_module(library(option)).
52:- use_module(library(lists)).
53:- use_module(library(time)).
54:- use_module(library(error)).
55:- use_module(library(settings)).
56:- use_module(library(uri)).
57:- use_module(library(apply)).
58:- use_module(library(http/mimetype)).
59:- use_module(library(http/http_path)).
60:- use_module(library(http/http_header)).
61:- use_module(library(http/thread_httpd)).
62
63:- predicate_options(http_404/2, 1, [index(any)]).
64:- predicate_options(http_reply_file/3, 2,
65 [ cache(boolean),
66 mime_type(any),
67 static_gzip(boolean),
68 pass_to(http_safe_file/2, 2),
69 headers(list)
70 ]).
71:- predicate_options(http_safe_file/2, 2, [unsafe(boolean)]).
72:- predicate_options(http_switch_protocol/2, 2, []).
73
94
95:- setting(http:time_limit, nonneg, 300,
96 'Time limit handling a single query (0=infinite)').
97
184
185:- dynamic handler/4. 186:- multifile handler/4.
187:- dynamic generation/1.
188
189:- meta_predicate
190 http_handler(+, :, +),
191 http_current_handler(?, :),
192 http_current_handler(?, :, ?),
193 http_switch_protocol(2, +).
194
195http_handler(Path, Pred, Options) :-
196 strip_module(Pred, M, P),
197 compile_handler(Path, M:P, Options, Clause),
198 next_generation,
199 assert(Clause).
200
201:- multifile
202 system:term_expansion/2.
203
204system:term_expansion((:- http_handler(Path, Pred, Options)), Clause) :-
205 \+ current_prolog_flag(xref, true),
206 prolog_load_context(module, M),
207 compile_handler(Path, M:Pred, Options, Clause),
208 next_generation.
209
210
222
223http_delete_handler(id(Id)) :-
224 !,
225 clause(handler(_Path, _:Pred, _, Options), true, Ref),
226 functor(Pred, DefID, _),
227 option(id(Id0), Options, DefID),
228 Id == Id0,
229 erase(Ref),
230 next_generation.
231http_delete_handler(path(Path)) :-
232 !,
233 retractall(handler(Path, _Pred, _, _Options)),
234 next_generation.
235http_delete_handler(Path) :-
236 http_delete_handler(path(Path)).
237
238
243
244next_generation :-
245 retractall(id_location_cache(_,_)),
246 with_mutex(http_dispatch, next_generation_unlocked).
247
248next_generation_unlocked :-
249 retract(generation(G0)),
250 !,
251 G is G0 + 1,
252 assert(generation(G)).
253next_generation_unlocked :-
254 assert(generation(1)).
255
256current_generation(G) :-
257 with_mutex(http_dispatch, generation(G)),
258 !.
259current_generation(0).
260
261
268
269compile_handler(prefix(Path), Pred, Options,
270 http_dispatch:handler(Path, Pred, true, Options)) :-
271 !,
272 check_path(Path, Path1),
273 print_message(warning, http_dispatch(prefix(Path1))).
274compile_handler(Path, Pred, Options0,
275 http_dispatch:handler(Path1, Pred, IsPrefix, Options)) :-
276 check_path(Path, Path1),
277 ( select(prefix, Options0, Options1)
278 -> IsPrefix = true
279 ; IsPrefix = false,
280 Options1 = Options0
281 ),
282 combine_methods(Options1, Options).
283
288
289combine_methods(Options0, Options) :-
290 collect_methods(Options0, Options1, Methods),
291 ( Methods == []
292 -> Options = Options0
293 ; append(Methods, Flat),
294 sort(Flat, Unique),
295 ( memberchk('*', Unique)
296 -> Final = '*'
297 ; Final = Unique
298 ),
299 Options = [methods(Final)|Options1]
300 ).
301
302collect_methods([], [], []).
303collect_methods([method(M)|T0], T, [[M]|TM]) :-
304 !,
305 ( M == '*'
306 -> true
307 ; must_be_method(M)
308 ),
309 collect_methods(T0, T, TM).
310collect_methods([methods(M)|T0], T, [M|TM]) :-
311 !,
312 must_be(list, M),
313 maplist(must_be_method, M),
314 collect_methods(T0, T, TM).
315collect_methods([H|T0], [H|T], TM) :-
316 !,
317 collect_methods(T0, T, TM).
318
319must_be_method(M) :-
320 must_be(atom, M),
321 ( method(M)
322 -> true
323 ; domain_error(http_method, M)
324 ).
325
326method(get).
327method(put).
328method(head).
329method(post).
330method(delete).
331method(patch).
332method(options).
333method(trace).
334
335
348
349check_path(Path, Path) :-
350 atom(Path),
351 !,
352 ( sub_atom(Path, 0, _, _, /)
353 -> true
354 ; domain_error(absolute_http_location, Path)
355 ).
356check_path(Alias, AliasOut) :-
357 compound(Alias),
358 Alias =.. [Name, Relative],
359 !,
360 to_atom(Relative, Local),
361 ( sub_atom(Local, 0, _, _, /)
362 -> domain_error(relative_location, Relative)
363 ; AliasOut =.. [Name, Local]
364 ).
365check_path(PathSpec, _) :-
366 type_error(path_or_alias, PathSpec).
367
368to_atom(Atom, Atom) :-
369 atom(Atom),
370 !.
371to_atom(Path, Atom) :-
372 phrase(path_to_list(Path), Components),
373 !,
374 atomic_list_concat(Components, '/', Atom).
375to_atom(Path, _) :-
376 ground(Path),
377 !,
378 type_error(relative_location, Path).
379to_atom(Path, _) :-
380 instantiation_error(Path).
381
382path_to_list(Var) -->
383 { var(Var),
384 !,
385 fail
386 }.
387path_to_list(A/B) -->
388 path_to_list(A),
389 path_to_list(B).
390path_to_list(Atom) -->
391 { atom(Atom) },
392 [Atom].
393
394
395
399
400http_dispatch(Request) :-
401 memberchk(path(Path), Request),
402 find_handler(Path, Pred, Options),
403 supports_method(Request, Options),
404 authentication(Options, Request, Fields),
405 append(Fields, Request, AuthRequest),
406 action(Pred, AuthRequest, Options).
407
408
413
414http_current_handler(Path, Closure) :-
415 atom(Path),
416 !,
417 path_tree(Tree),
418 find_handler(Tree, Path, Closure, _).
419http_current_handler(Path, M:C) :-
420 handler(Spec, M:C, _, _),
421 http_absolute_location(Spec, Path, []).
422
427
428http_current_handler(Path, Closure, Options) :-
429 atom(Path),
430 !,
431 path_tree(Tree),
432 find_handler(Tree, Path, Closure, Options).
433http_current_handler(Path, M:C, Options) :-
434 handler(Spec, M:C, _, _),
435 http_absolute_location(Spec, Path, []),
436 path_tree(Tree),
437 find_handler(Tree, Path, _, Options).
438
439
459
460:- dynamic
461 id_location_cache/2.
462
463http_location_by_id(ID, Location) :-
464 must_be(ground, ID),
465 id_location_cache(ID, L0),
466 !,
467 Location = L0.
468http_location_by_id(ID, Location) :-
469 findall(P-L, location_by_id(ID, L, P), List),
470 keysort(List, RevSorted),
471 reverse(RevSorted, Sorted),
472 ( Sorted = [_-One]
473 -> assert(id_location_cache(ID, One)),
474 Location = One
475 ; List == []
476 -> existence_error(http_handler_id, ID)
477 ; List = [P0-Best,P1-_|_]
478 -> ( P0 == P1
479 -> print_message(warning,
480 http_dispatch(ambiguous_id(ID, Sorted, Best)))
481 ; true
482 ),
483 assert(id_location_cache(ID, Best)),
484 Location = Best
485 ).
486
487location_by_id(ID, Location, Priority) :-
488 location_by_id_raw(ID, L0, Priority),
489 to_path(L0, Location).
490
491to_path(prefix(Path0), Path) :- 492 !,
493 add_prefix(Path0, Path).
494to_path(Path0, Path) :-
495 atomic(Path0), 496 !,
497 add_prefix(Path0, Path).
498to_path(Spec, Path) :- 499 http_absolute_location(Spec, Path, []).
500
501add_prefix(P0, P) :-
502 ( catch(setting(http:prefix, Prefix), _, fail),
503 Prefix \== ''
504 -> atom_concat(Prefix, P0, P)
505 ; P = P0
506 ).
507
508location_by_id_raw(ID, Location, Priority) :-
509 handler(Location, _, _, Options),
510 option(id(ID), Options),
511 option(priority(P0), Options, 0),
512 Priority is P0+1000. 513location_by_id_raw(ID, Location, Priority) :-
514 handler(Location, M:C, _, Options),
515 option(priority(Priority), Options, 0),
516 functor(C, PN, _),
517 ( ID = M:PN
518 ; ID = PN
519 ),
520 !.
521
522
562
563http_link_to_id(HandleID, path_postfix(File), HREF) :-
564 !,
565 http_location_by_id(HandleID, HandlerLocation),
566 uri_encoded(path, File, EncFile),
567 directory_file_path(HandlerLocation, EncFile, Location),
568 uri_data(path, Components, Location),
569 uri_components(HREF, Components).
570http_link_to_id(HandleID, Parameters, HREF) :-
571 must_be(list, Parameters),
572 http_location_by_id(HandleID, Location),
573 uri_data(path, Components, Location),
574 uri_query_components(String, Parameters),
575 uri_data(search, Components, String),
576 uri_components(HREF, Components).
577
582
583http_reload_with_parameters(Request, NewParams, HREF) :-
584 memberchk(path(Path), Request),
585 ( memberchk(search(Params), Request)
586 -> true
587 ; Params = []
588 ),
589 merge_options(NewParams, Params, AllParams),
590 uri_query_components(Search, AllParams),
591 uri_data(path, Data, Path),
592 uri_data(search, Data, Search),
593 uri_components(HREF, Data).
594
595
597
598:- multifile
599 html_write:expand_attribute_value//1.
600
601html_write:expand_attribute_value(location_by_id(ID)) -->
602 { http_location_by_id(ID, Location) },
603 html_write:html_quoted_attribute(Location).
604
605
614
615:- multifile
616 http:authenticate/3.
617
618authentication([], _, []).
619authentication([authentication(Type)|Options], Request, Fields) :-
620 !,
621 ( http:authenticate(Type, Request, XFields)
622 -> append(XFields, More, Fields),
623 authentication(Options, Request, More)
624 ; memberchk(path(Path), Request),
625 permission_error(access, http_location, Path)
626 ).
627authentication([_|Options], Request, Fields) :-
628 authentication(Options, Request, Fields).
629
630
646
647find_handler(Path, Action, Options) :-
648 path_tree(Tree),
649 ( find_handler(Tree, Path, Action, Options)
650 -> true
651 ; \+ sub_atom(Path, _, _, 0, /),
652 atom_concat(Path, /, Dir),
653 find_handler(Tree, Dir, Action, Options)
654 -> throw(http_reply(moved(Dir)))
655 ; throw(error(existence_error(http_location, Path), _))
656 ).
657
658
659find_handler([node(prefix(Prefix), PAction, POptions, Children)|_],
660 Path, Action, Options) :-
661 sub_atom(Path, 0, _, After, Prefix),
662 !,
663 ( option(hide_children(false), POptions, false),
664 find_handler(Children, Path, Action, Options)
665 -> true
666 ; Action = PAction,
667 path_info(After, Path, POptions, Options)
668 ).
669find_handler([node(Path, Action, Options, _)|_], Path, Action, Options) :- !.
670find_handler([_|Tree], Path, Action, Options) :-
671 find_handler(Tree, Path, Action, Options).
672
673path_info(0, _, Options,
674 [prefix(true)|Options]) :- !.
675path_info(After, Path, Options,
676 [path_info(PathInfo),prefix(true)|Options]) :-
677 sub_atom(Path, _, After, 0, PathInfo).
678
679
687
688supports_method(Request, Options) :-
689 ( option(methods(Methods), Options)
690 -> ( Methods == '*'
691 -> true
692 ; memberchk(method(Method), Request),
693 memberchk(Method, Methods)
694 )
695 ; true
696 ),
697 !.
698supports_method(Request, _Options) :-
699 memberchk(path(Location), Request),
700 memberchk(method(Method), Request),
701 permission_error(http_method, Method, Location).
702
703
710
711action(Action, Request, Options) :-
712 memberchk(chunked, Options),
713 !,
714 format('Transfer-encoding: chunked~n'),
715 spawn_action(Action, Request, Options).
716action(Action, Request, Options) :-
717 spawn_action(Action, Request, Options).
718
719spawn_action(Action, Request, Options) :-
720 option(spawn(Spawn), Options),
721 !,
722 spawn_options(Spawn, SpawnOption),
723 http_spawn(time_limit_action(Action, Request, Options), SpawnOption).
724spawn_action(Action, Request, Options) :-
725 time_limit_action(Action, Request, Options).
726
727spawn_options([], []) :- !.
728spawn_options(Pool, Options) :-
729 atom(Pool),
730 !,
731 Options = [pool(Pool)].
732spawn_options(List, List).
733
734time_limit_action(Action, Request, Options) :-
735 ( option(time_limit(TimeLimit), Options),
736 TimeLimit \== default
737 -> true
738 ; setting(http:time_limit, TimeLimit)
739 ),
740 number(TimeLimit),
741 TimeLimit > 0,
742 !,
743 call_with_time_limit(TimeLimit, call_action(Action, Request, Options)).
744time_limit_action(Action, Request, Options) :-
745 call_action(Action, Request, Options).
746
747
751
752call_action(reply_file(File, FileOptions), Request, _Options) :-
753 !,
754 http_reply_file(File, FileOptions, Request).
755call_action(Pred, Request, Options) :-
756 memberchk(path_info(PathInfo), Options),
757 !,
758 call_action(Pred, [path_info(PathInfo)|Request]).
759call_action(Pred, Request, _Options) :-
760 call_action(Pred, Request).
761
762call_action(Pred, Request) :-
763 ( call(Pred, Request)
764 -> true
765 ; extend(Pred, [Request], Goal),
766 throw(error(goal_failed(Goal), _))
767 ).
768
769extend(Var, _, Var) :-
770 var(Var),
771 !.
772extend(M:G0, Extra, M:G) :-
773 extend(G0, Extra, G).
774extend(G0, Extra, G) :-
775 G0 =.. List,
776 append(List, Extra, List2),
777 G =.. List2.
778
812
813http_reply_file(File, Options, Request) :-
814 http_safe_file(File, Options),
815 absolute_file_name(File, Path,
816 [ access(read)
817 ]),
818 ( option(cache(true), Options, true)
819 -> ( memberchk(if_modified_since(Since), Request),
820 time_file(Path, Time),
821 catch(http_timestamp(Time, Since), _, fail)
822 -> throw(http_reply(not_modified))
823 ; true
824 ),
825 ( memberchk(range(Range), Request)
826 -> Reply = file(Type, Path, Range)
827 ; option(static_gzip(true), Options),
828 accepts_encoding(Request, gzip),
829 file_name_extension(Path, gz, PathGZ),
830 access_file(PathGZ, read),
831 time_file(PathGZ, TimeGZ),
832 time_file(Path, Time),
833 TimeGZ >= Time
834 -> Reply = gzip_file(Type, PathGZ)
835 ; Reply = file(Type, Path)
836 )
837 ; Reply = tmp_file(Type, Path)
838 ),
839 ( option(mime_type(Type), Options)
840 -> true
841 ; file_mime_type(Path, Type)
842 -> true
843 ; Type = text/plain 844 ),
845 option(headers(Headers), Options, []),
846 throw(http_reply(Reply, Headers)).
847
848accepts_encoding(Request, Enc) :-
849 memberchk(accept_encoding(Accept), Request),
850 split_string(Accept, ",", " ", Parts),
851 member(Part, Parts),
852 split_string(Part, ";", " ", [EncS|_]),
853 atom_string(Enc, EncS).
854
855
865
866http_safe_file(File, _) :-
867 var(File),
868 !,
869 instantiation_error(File).
870http_safe_file(_, Options) :-
871 option(unsafe(true), Options, false),
872 !.
873http_safe_file(File, _) :-
874 http_safe_file(File).
875
876http_safe_file(File) :-
877 compound(File),
878 functor(File, _, 1),
879 !,
880 arg(1, File, Name),
881 safe_name(Name, File).
882http_safe_file(Name) :-
883 ( is_absolute_file_name(Name)
884 -> permission_error(read, file, Name)
885 ; true
886 ),
887 safe_name(Name, Name).
888
889safe_name(Name, _) :-
890 must_be(atom, Name),
891 prolog_to_os_filename(FileName, Name),
892 \+ unsafe_name(FileName),
893 !.
894safe_name(_, Spec) :-
895 permission_error(read, file, Spec).
896
897unsafe_name(Name) :- Name == '..'.
898unsafe_name(Name) :- sub_atom(Name, 0, _, _, '../').
899unsafe_name(Name) :- sub_atom(Name, _, _, _, '/../').
900unsafe_name(Name) :- sub_atom(Name, _, _, 0, '/..').
901
902
919
920http_redirect(How, To, Request) :-
921 ( To = location_by_id(Id)
922 -> http_location_by_id(Id, URL)
923 ; memberchk(path(Base), Request),
924 http_absolute_location(To, URL, [relative_to(Base)])
925 ),
926 must_be(oneof([moved, moved_temporary, see_other]), How),
927 Term =.. [How,URL],
928 throw(http_reply(Term)).
929
930
942
943http_404(Options, Request) :-
944 option(index(Index), Options),
945 \+ ( option(path_info(PathInfo), Request),
946 PathInfo \== ''
947 ),
948 !,
949 http_redirect(moved, Index, Request).
950http_404(_Options, Request) :-
951 option(path(Path), Request),
952 !,
953 throw(http_reply(not_found(Path))).
954http_404(_Options, Request) :-
955 domain_error(http_request, Request).
956
957
988
990
991http_switch_protocol(Goal, Options) :-
992 throw(http_reply(switching_protocols(Goal, Options))).
993
994
995 998
1012
1013path_tree(Tree) :-
1014 current_generation(G),
1015 nb_current(http_dispatch_tree, G-Tree),
1016 !. 1017path_tree(Tree) :-
1018 path_tree_nocache(Tree),
1019 current_generation(G),
1020 nb_setval(http_dispatch_tree, G-Tree).
1021
1022path_tree_nocache(Tree) :-
1023 findall(Prefix, prefix_handler(Prefix, _, _), Prefixes0),
1024 sort(Prefixes0, Prefixes),
1025 prefix_tree(Prefixes, [], PTree),
1026 prefix_options(PTree, [], OPTree),
1027 add_paths_tree(OPTree, Tree).
1028
1029prefix_handler(Prefix, Action, Options) :-
1030 handler(Spec, Action, true, Options),
1031 http_absolute_location(Spec, Prefix, []).
1032
1036
1037prefix_tree([], Tree, Tree).
1038prefix_tree([H|T], Tree0, Tree) :-
1039 insert_prefix(H, Tree0, Tree1),
1040 prefix_tree(T, Tree1, Tree).
1041
1042insert_prefix(Prefix, Tree0, Tree) :-
1043 select(P-T, Tree0, Tree1),
1044 sub_atom(Prefix, 0, _, _, P),
1045 !,
1046 insert_prefix(Prefix, T, T1),
1047 Tree = [P-T1|Tree1].
1048insert_prefix(Prefix, Tree, [Prefix-[]|Tree]).
1049
1050
1056
1057prefix_options([], _, []).
1058prefix_options([P-C|T0], DefOptions,
1059 [node(prefix(P), Action, Options, Children)|T]) :-
1060 once(prefix_handler(P, Action, Options0)),
1061 merge_options(Options0, DefOptions, Options),
1062 delete(Options, id(_), InheritOpts),
1063 prefix_options(C, InheritOpts, Children),
1064 prefix_options(T0, DefOptions, T).
1065
1066
1070
1071add_paths_tree(OPTree, Tree) :-
1072 findall(path(Path, Action, Options),
1073 plain_path(Path, Action, Options),
1074 Triples),
1075 add_paths_tree(Triples, OPTree, Tree).
1076
1077add_paths_tree([], Tree, Tree).
1078add_paths_tree([path(Path, Action, Options)|T], Tree0, Tree) :-
1079 add_path_tree(Path, Action, Options, [], Tree0, Tree1),
1080 add_paths_tree(T, Tree1, Tree).
1081
1082
1087
1088plain_path(Path, Action, Options) :-
1089 handler(Spec, Action, false, Options),
1090 catch(http_absolute_location(Spec, Path, []), E,
1091 (print_message(error, E), fail)).
1092
1093
1099
1100add_path_tree(Path, Action, Options0, DefOptions, [],
1101 [node(Path, Action, Options, [])]) :-
1102 !,
1103 merge_options(Options0, DefOptions, Options).
1104add_path_tree(Path, Action, Options, _,
1105 [node(prefix(Prefix), PA, DefOptions, Children0)|RestTree],
1106 [node(prefix(Prefix), PA, DefOptions, Children)|RestTree]) :-
1107 sub_atom(Path, 0, _, _, Prefix),
1108 !,
1109 delete(DefOptions, id(_), InheritOpts),
1110 add_path_tree(Path, Action, Options, InheritOpts, Children0, Children).
1111add_path_tree(Path, Action, Options1, DefOptions, [H0|T], [H|T]) :-
1112 H0 = node(Path, _, Options2, _),
1113 option(priority(P1), Options1, 0),
1114 option(priority(P2), Options2, 0),
1115 P1 >= P2,
1116 !,
1117 merge_options(Options1, DefOptions, Options),
1118 H = node(Path, Action, Options, []).
1119add_path_tree(Path, Action, Options, DefOptions, [H|T0], [H|T]) :-
1120 add_path_tree(Path, Action, Options, DefOptions, T0, T).
1121
1122
1123 1126
1127:- multifile
1128 prolog:message/3.
1129
1130prolog:message(http_dispatch(ambiguous_id(ID, _List, Selected))) -->
1131 [ 'HTTP dispatch: ambiguous handler ID ~q (selected ~q)'-[ID, Selected]
1132 ].
1133prolog:message(http_dispatch(prefix(_Path))) -->
1134 [ 'HTTP dispatch: prefix(Path) is replaced by the option prefix'-[]
1135 ].
1136
1137
1138 1141
1142:- multifile
1143 prolog:meta_goal/2.
1144:- dynamic
1145 prolog:meta_goal/2.
1146
1147prolog:meta_goal(http_handler(_, G, _), [G+1]).
1148prolog:meta_goal(http_current_handler(_, G), [G+1]).
1149
1150
1151 1154
1156
1157:- multifile
1158 prolog_edit:locate/3.
1159
1160prolog_edit:locate(Path, Spec, Location) :-
1161 atom(Path),
1162 sub_atom(Path, 0, _, _, /),
1163 Pred = _M:_H,
1164 catch(http_current_handler(Path, Pred), _, fail),
1165 closure_name_arity(Pred, 1, PI),
1166 prolog_edit:locate(PI, Spec, Location).
1167
1168closure_name_arity(M:Term, Extra, M:Name/Arity) :-
1169 !,
1170 callable(Term),
1171 functor(Term, Name, Arity0),
1172 Arity is Arity0 + Extra.
1173closure_name_arity(Term, Extra, Name/Arity) :-
1174 callable(Term),
1175 functor(Term, Name, Arity0),
1176 Arity is Arity0 + Extra.
1177
1178
1179 1182
1183:- listen(settings(changed(http:prefix, _, _)),
1184 next_generation).
1185
1186:- multifile
1187 user:message_hook/3.
1188:- dynamic
1189 user:message_hook/3.
1190
1191user:message_hook(make(done(Reload)), _Level, _Lines) :-
1192 Reload \== [],
1193 next_generation,
1194 fail.