yap 6.2.2-6 / usr / share / Yap / http / http_path.pl

/*  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.