288 lines
8.3 KiB
Perl
288 lines
8.3 KiB
Perl
|
/* Part of SWI-Prolog
|
||
|
|
|
||
|
|
Author: Jan Wielemaker
|
||
|
|
E-mail: J.Wielemaker@uva.nl
|
||
|
|
WWW: http://www.swi-prolog.org
|
||
|
|
Copyright (C): 2008, University of Amsterdam
|
||
|
|
|
||
|
|
This program is free software; you can redistribute it and/or
|
||
|
|
modify it under the terms of the GNU General Public License
|
||
|
|
as published by the Free Software Foundation; either version 2
|
||
|
|
of the License, or (at your option) any later version.
|
||
|
|
|
||
|
|
This program is distributed in the hope that it will be useful,
|
||
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
|
|
GNU General Public License for more details.
|
||
|
|
|
||
|
|
You should have received a copy of the GNU General Public
|
||
|
|
License along with this library; if not, write to the Free Software
|
||
|
|
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
|
||
|
|
|
||
|
|
As a special exception, if you link this library with other files,
|
||
|
|
compiled with a Free Software compiler, to produce an executable, this
|
||
|
|
library does not by itself cause the resulting executable to be covered
|
||
|
|
by the GNU General Public License. This exception does not however
|
||
|
|
invalidate any other reasons why the executable file might be covered by
|
||
|
|
the GNU General Public License.
|
||
|
|
*/
|
||
|
|
|
||
|
|
:- module(http_path,
|
||
|
|
[ http_absolute_location/3 % +Spec, -Path, +Options
|
||
|
|
]).
|
||
|
|
:- use_module(library(lists)).
|
||
|
|
:- use_module(library(error)).
|
||
|
|
:- use_module(library(apply)).
|
||
|
|
:- use_module(library(debug)).
|
||
|
|
:- use_module(library(option)).
|
||
|
|
:- use_module(library(settings)).
|
||
|
|
:- use_module(library(broadcast)).
|
||
|
|
:- use_module(library(url)).
|
||
|
|
|
||
|
|
|
||
|
|
/** <module> Abstract specification of HTTP server locations
|
||
|
|
|
||
|
|
This module provides an abstract specification of HTTP server locations
|
||
|
|
that is inspired on absolute_file_name/3. The specification is done by
|
||
|
|
adding rules to the dynamic multifile predicate http:location/3. The
|
||
|
|
speficiation is very similar to user:file_search_path/2, but takes an
|
||
|
|
additional argument with options. Currently only one option is defined:
|
||
|
|
|
||
|
|
* priority(+Integer)
|
||
|
|
If two rules match, take the one with highest priority. Using
|
||
|
|
priorities is needed because we want to be able to overrule
|
||
|
|
paths, but we do not want to become dependent on clause ordering.
|
||
|
|
|
||
|
|
The default priority is 0. Note however that notably libraries may
|
||
|
|
decide to provide a fall-back using a negative priority. We suggest
|
||
|
|
-100 for such cases.
|
||
|
|
|
||
|
|
This library predefines three locations at priority -100: The =icons=
|
||
|
|
and =css= aliases are intended for images and css files and are backed
|
||
|
|
up by file a file-search-path that allows finding the icons and css
|
||
|
|
files that belong to the server infrastructure (e.g., http_dirindex/2).
|
||
|
|
|
||
|
|
* root
|
||
|
|
The root of the server. Default is /, but this may be overruled
|
||
|
|
the the setting (see setting/2) =|http:prefix|=
|
||
|
|
|
||
|
|
Here is an example that binds =|/login|= to login/1. The user can reuse
|
||
|
|
this application while moving all locations using a new rule for the
|
||
|
|
admin location with the option =|[priority(10)]|=.
|
||
|
|
|
||
|
|
==
|
||
|
|
:- multifile http:location/3.
|
||
|
|
:- dynamic http:location/3.
|
||
|
|
|
||
|
|
http:location(admin, /, []).
|
||
|
|
|
||
|
|
:- http_handler(admin(login), login, []).
|
||
|
|
|
||
|
|
login(Request) :-
|
||
|
|
...
|
||
|
|
==
|
||
|
|
|
||
|
|
@tbd Make this module replace the http:prefix option.
|
||
|
|
@tbd Remove hard-wired support for prefix().
|
||
|
|
*/
|
||
|
|
|
||
|
|
:- multifile
|
||
|
|
http:location/3. % Alias, Expansion, Options
|
||
|
|
:- dynamic
|
||
|
|
http:location/3. % Alias, Expansion, Options
|
||
|
|
|
||
|
|
http:location(root, Root, [priority(-100)]) :-
|
||
|
|
( catch(setting(http:prefix, Prefix), _, fail),
|
||
|
|
Prefix \== ''
|
||
|
|
-> Root = Prefix
|
||
|
|
; Root = (/)
|
||
|
|
).
|
||
|
|
|
||
|
|
|
||
|
|
%% http_absolute_location(+Spec, -Path, +Options) is det.
|
||
|
|
%
|
||
|
|
% Path is the HTTP location for the abstract specification Spec.
|
||
|
|
% Options:
|
||
|
|
%
|
||
|
|
% * relative_to(Base)
|
||
|
|
% Path is made relative to Base. Default is to generate
|
||
|
|
% absolute URLs.
|
||
|
|
|
||
|
|
:- dynamic
|
||
|
|
location_cache/3.
|
||
|
|
|
||
|
|
http_absolute_location(Spec, Path, Options) :-
|
||
|
|
must_be(ground, Spec),
|
||
|
|
option(relative_to(Base), Options, /),
|
||
|
|
absolute_location(Spec, Base, Path, Options),
|
||
|
|
debug(http_path, '~q (~q) --> ~q', [Spec, Base, Path]).
|
||
|
|
|
||
|
|
absolute_location(Spec, Base, Path, _Options) :-
|
||
|
|
location_cache(Spec, Base, Cache), !,
|
||
|
|
Path = Cache.
|
||
|
|
absolute_location(Spec, Base, Path, Options) :-
|
||
|
|
expand_location(Spec, Base, L, Options),
|
||
|
|
assert(location_cache(Spec, Base, L)),
|
||
|
|
Path = L.
|
||
|
|
|
||
|
|
expand_location(Spec, Base, Path, _Options) :-
|
||
|
|
atomic(Spec), !,
|
||
|
|
relative_to(Base, Spec, Path).
|
||
|
|
expand_location(Spec, _Base, Path, Options) :-
|
||
|
|
Spec =.. [Alias, Sub],
|
||
|
|
http_location_path(Alias, Parent),
|
||
|
|
absolute_location(Parent, /, ParentLocation, Options),
|
||
|
|
phrase(path_list(Sub), List),
|
||
|
|
atomic_list_concat(List, /, SubAtom),
|
||
|
|
( ParentLocation == ''
|
||
|
|
-> Path = SubAtom
|
||
|
|
; sub_atom(ParentLocation, _, _, 0, /)
|
||
|
|
-> atom_concat(ParentLocation, SubAtom, Path)
|
||
|
|
; atomic_list_concat([ParentLocation, SubAtom], /, Path)
|
||
|
|
).
|
||
|
|
|
||
|
|
|
||
|
|
%% http_location_path(+Alias, -Expansion) is det.
|
||
|
|
%
|
||
|
|
% Expansion is the expanded HTTP location for Alias. As we have no
|
||
|
|
% condition search, we demand a single expansion for an alias. An
|
||
|
|
% ambiguous alias results in a printed warning. A lacking alias
|
||
|
|
% results in an exception.
|
||
|
|
%
|
||
|
|
% @error existence_error(http_alias, Alias)
|
||
|
|
|
||
|
|
http_location_path(Alias, Path) :-
|
||
|
|
findall(P-L, http_location_path(Alias, L, P), Pairs),
|
||
|
|
keysort(Pairs, Sorted0),
|
||
|
|
reverse(Sorted0, Result),
|
||
|
|
( Result = [_-One]
|
||
|
|
-> Path = One
|
||
|
|
; Result == []
|
||
|
|
-> existence_error(http_location, Spec)
|
||
|
|
; Result = [P-Best,P2-_|_],
|
||
|
|
P \== P2
|
||
|
|
-> Path = Best
|
||
|
|
; Result = [_-First|_],
|
||
|
|
pairs_values(Result, Paths),
|
||
|
|
print_message(warning, http(ambiguous_location(Spec, Paths))),
|
||
|
|
Path = First
|
||
|
|
).
|
||
|
|
|
||
|
|
|
||
|
|
%% http_location_path(+Alias, -Path, -Priority) is nondet.
|
||
|
|
%
|
||
|
|
% @tbd prefix(Path) is discouraged; use root(Path)
|
||
|
|
|
||
|
|
http_location_path(Alias, Path, Priority) :-
|
||
|
|
http:location(Alias, Path, Options),
|
||
|
|
option(priority(Priority), Options, 0).
|
||
|
|
http_location_path(prefix, Path, 0) :-
|
||
|
|
( catch(setting(http:prefix, Prefix), _, fail),
|
||
|
|
Prefix \== ''
|
||
|
|
-> ( sub_atom(Prefix, 0, _, _, /)
|
||
|
|
-> Path = Prefix
|
||
|
|
; atom_concat(/, Prefix, Path)
|
||
|
|
)
|
||
|
|
; Path = /
|
||
|
|
).
|
||
|
|
|
||
|
|
|
||
|
|
%% relative_to(+Base, +Path, -AbsPath) is det.
|
||
|
|
%
|
||
|
|
% AbsPath is an absolute URL location created from Base and Path.
|
||
|
|
% The result is cleaned
|
||
|
|
|
||
|
|
relative_to(/, Path, Path) :- !.
|
||
|
|
relative_to(_Base, Path, Path) :-
|
||
|
|
sub_atom(Path, 0, _, _, /), !.
|
||
|
|
relative_to(Base, Local, Path) :-
|
||
|
|
sub_atom(Base, 0, _, _, /), !, % file version
|
||
|
|
path_segments(Base, BaseSegments),
|
||
|
|
append(BaseDir, [_], BaseSegments) ->
|
||
|
|
path_segments(Local, LocalSegments),
|
||
|
|
append(BaseDir, LocalSegments, Segments0),
|
||
|
|
clean_segments(Segments0, Segments),
|
||
|
|
path_segments(Path, Segments).
|
||
|
|
relative_to(Base, Local, Global) :-
|
||
|
|
global_url(Local, Base, Global).
|
||
|
|
|
||
|
|
path_segments(Path, Segments) :-
|
||
|
|
atomic_list_concat(Segments, /, Path).
|
||
|
|
|
||
|
|
%% clean_segments(+SegmentsIn, -SegmentsOut) is det.
|
||
|
|
%
|
||
|
|
% Clean a path represented as a segment list, removing empty
|
||
|
|
% segments and resolving .. based on syntax.
|
||
|
|
|
||
|
|
clean_segments([''|T0], [''|T]) :- !,
|
||
|
|
exclude(empty_segment, T0, T1),
|
||
|
|
clean_parent_segments(T1, T).
|
||
|
|
clean_segments(T0, T) :-
|
||
|
|
exclude(empty_segment, T0, T1),
|
||
|
|
clean_parent_segments(T1, T).
|
||
|
|
|
||
|
|
clean_parent_segments([], []).
|
||
|
|
clean_parent_segments([..|T0], T) :- !,
|
||
|
|
clean_parent_segments(T0, T).
|
||
|
|
clean_parent_segments([_,..|T0], T) :- !,
|
||
|
|
clean_parent_segments(T0, T).
|
||
|
|
clean_parent_segments([H|T0], [H|T]) :-
|
||
|
|
clean_parent_segments(T0, T).
|
||
|
|
|
||
|
|
empty_segment('').
|
||
|
|
empty_segment('.').
|
||
|
|
|
||
|
|
|
||
|
|
%% path_list(+Spec, -List) is det.
|
||
|
|
%
|
||
|
|
% Translate seg1/seg2/... into [seg1,seg2,...].
|
||
|
|
%
|
||
|
|
% @error instantiation_error
|
||
|
|
% @error type_error(atomic, X)
|
||
|
|
|
||
|
|
path_list(Var) -->
|
||
|
|
{ var(Var), !,
|
||
|
|
instantiation_error(Var)
|
||
|
|
}.
|
||
|
|
path_list(A/B) --> !,
|
||
|
|
path_list(A),
|
||
|
|
path_list(B).
|
||
|
|
path_list(.) --> !,
|
||
|
|
[].
|
||
|
|
path_list(A) -->
|
||
|
|
{ must_be(atomic, A) },
|
||
|
|
[A].
|
||
|
|
|
||
|
|
|
||
|
|
/*******************************
|
||
|
|
* MESSAGES *
|
||
|
|
*******************************/
|
||
|
|
|
||
|
|
:- multifile
|
||
|
|
prolog:message/3.
|
||
|
|
|
||
|
|
prolog:message(http(ambiguous_location(Spec, Paths))) -->
|
||
|
|
[ 'http_absolute_location/2: ambiguous specification: ~q: ~p'-[Spec, Paths]
|
||
|
|
].
|
||
|
|
|
||
|
|
|
||
|
|
/*******************************
|
||
|
|
* CACHE CLEANUP *
|
||
|
|
*******************************/
|
||
|
|
|
||
|
|
clean_location_cache :-
|
||
|
|
retractall(location_cache(_,_,_)).
|
||
|
|
|
||
|
|
:- listen(settings(changed(http:prefix, _, _)),
|
||
|
|
clean_location_cache).
|
||
|
|
|
||
|
|
:- multifile
|
||
|
|
user:message_hook/3.
|
||
|
|
:- dynamic
|
||
|
|
user:message_hook/3.
|
||
|
|
|
||
|
|
user:message_hook(make(done(Reload)), _Level, _Lines) :-
|
||
|
|
Reload \== [],
|
||
|
|
clean_location_cache,
|
||
|
|
fail.
|