http_path.pl

/*  Part of SWI-Prolog

    Author:        Jan Wielemaker
    E-mail:        J.Wielemaker@vu.nl
    WWW:           http://www.swi-prolog.org
    Copyright (C): 2008-2012, University of Amsterdam
			      VU University 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., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  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_uri/2,	% +Spec, -URI
	    http_absolute_location/3,	% +Spec, -Path, +Options
	    http_clean_location_cache/0
	  ]).
:- 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(uri)).
:- use_module(library(http/http_host)).
:- use_module(library(http/http_wrapper)).


:- predicate_options(http_absolute_location/3, 3, [relative_to(atom)]).

/** <module> Abstract specification of HTTP server locations
@ingroup http

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

%%	http:location(+Alias, -Expansion, -Options) is nondet.
%
%	Multifile hook used to specify new  HTTP locations. Alias is the
%	name  of  the  abstract  path.  Expansion    is  either  a  term
%	Alias2(Relative), telling http_absolute_location/3  to translate
%	Alias by first translating Alias2 and then applying the relative
%	path Relative or, Expansion is an   absolute location, i.e., one
%	that starts with a =|/|=. Options   currently  only supports the
%	priority  of  the  path.  If  http:location/3  returns  multiple
%	solutions the one with the  highest   priority  is selected. The
%	default priority is 0.
%
%	This library provides  a  default   for  the  abstract  location
%	=root=. This defaults to the setting   http:prefix  or, when not
%	available to the  path  =|/|=.  It   is  adviced  to  define all
%	locations (ultimately) relative to  =root=.   For  example,  use
%	root('home.html') rather than =|'/home.html'|=.

:- 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_uri(+Spec, -URI) is det.
%
%	URI is the absolute (i.e., starting   with  =|http://|=) URI for
%	the abstract specification Spec. Use http_absolute_location/3 to
%	create references to locations on the same server.
%
%	@tbd	Distinguish =http= from =https=

http_absolute_uri(Spec, URI) :-
	http_current_host(_Request, Host, Port,
			  [ global(true)
			  ]),
	http_absolute_location(Spec, Path, []),
	uri_authority_data(host, AuthC, Host),
	(   Port == 80			% HTTP scheme
	->  true
	;   uri_authority_data(port, AuthC, Port)
	),
	uri_authority_components(Authority, AuthC),
	uri_data(path, Components, Path),
	uri_data(scheme, Components, http),
	uri_data(authority, Components, Authority),
	uri_components(URI, Components).


%%	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.
%
%	@see     http_absolute_uri/2 to create a reference that can be
%		 used on another server.

:- 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), !,
	(   uri_components(Spec, Components),
	    uri_data(scheme, Components, Scheme),
	    atom(Scheme)
	->  Path = 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),
	sort(Pairs, Sorted0),
	reverse(Sorted0, Result),
	(   Result = [_-One]
	->  Path = One
	;   Result == []
	->  existence_error(http_alias, Alias)
	;   Result = [P-Best,P2-_|_],
	    P \== P2
	->  Path = Best
	;   Result = [_-First|_],
	    pairs_values(Result, Paths),
	    print_message(warning, http(ambiguous_location(Alias, 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) :-
	uri_normalized(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		*
		 *******************************/

%%	http_clean_location_cache
%
%	HTTP locations resolved  through   http_absolute_location/3  are
%	cached.  This  predicate  wipes   the    cache.   The  cache  is
%	automatically wiped by make/0 and if  the setting http:prefix is
%	changed.

http_clean_location_cache :-
	retractall(location_cache(_,_,_)).

:- listen(settings(changed(http:prefix, _, _)),
	  http_clean_location_cache).

:- multifile
	user:message_hook/3.
:- dynamic
	user:message_hook/3.

user:message_hook(make(done(Reload)), _Level, _Lines) :-
	Reload \== [],
	http_clean_location_cache,
	fail.