Chris@0: /*  This file is part of ClioPatria.
Chris@0: 
Chris@0:     Author:
Chris@0:     HTTP:	http://e-culture.multimedian.nl/
Chris@0:     GITWEB:	http://gollem.science.uva.nl/git/ClioPatria.git
Chris@0:     GIT:	git://gollem.science.uva.nl/home/git/ClioPatria.git
Chris@0:     GIT:	http://gollem.science.uva.nl/home/git/ClioPatria.git
Chris@0:     Copyright:  2007, E-Culture/MultimediaN
Chris@0: 
Chris@0:     ClioPatria is free software: you can redistribute it and/or modify
Chris@0:     it under the terms of the GNU General Public License as published by
Chris@0:     the Free Software Foundation, either version 2 of the License, or
Chris@0:     (at your option) any later version.
Chris@0: 
Chris@0:     ClioPatria is distributed in the hope that it will be useful,
Chris@0:     but WITHOUT ANY WARRANTY; without even the implied warranty of
Chris@0:     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
Chris@0:     GNU General Public License for more details.
Chris@0: 
Chris@0:     You should have received a copy of the GNU General Public License
Chris@0:     along with ClioPatria.  If not, see <http://www.gnu.org/licenses/>.
Chris@0: */
Chris@0: 
Chris@0: :- module(http_prefix,
Chris@0: 	  [ http_setup_prefix_redirect/0,
Chris@0: 	    http_current_path/2			% +Request, -Path
Chris@0: 	  ]).
Chris@0: :- use_module(library('http/http_dispatch')).
Chris@0: :- use_module(library(settings)).
Chris@0: :- use_module(library(lists)).
Chris@0: :- use_module(library(debug)).
Chris@0: :- use_module(library(broadcast)).
Chris@0: 
Chris@0: /** <module> Set common prefix for all URLs
Chris@0: 
Chris@0: This module manages the setting  http:prefix   to  redirect all requests
Chris@0: below prefix to the root. It can be   used  to relocate an entire server
Chris@0: under a new root.
Chris@0: 
Chris@0: @author	Jan Wielemaker
Chris@0: */
Chris@0: 
Chris@0: :- setting(http:prefix, atom, env('SERQL_PREFIX', ''), 
Chris@0: 	   'Root of all URLs').
Chris@0: 
Chris@0: 
Chris@0: %%	http_setup_prefix_redirect is det.
Chris@0: %
Chris@0: %	If setting http:prefix is  active,  setup   an  HTTP  handler to
Chris@0: %	remove the prefix.
Chris@0: 
Chris@0: http_setup_prefix_redirect :-
Chris@0: 	remove_prefix_handler,
Chris@0: 	setting(http:prefix, Prefix),
Chris@0: 	Prefix \== '', !,
Chris@0: 	(   sub_atom(Prefix, _, _, 0, /)
Chris@0: 	->  ThePrefix = Prefix
Chris@0: 	;   atom_concat(Prefix, /, ThePrefix)
Chris@0: 	),
Chris@0: 	http_handler(prefix(ThePrefix), redirect_prefix(ThePrefix), []).
Chris@0: http_setup_prefix_redirect.
Chris@0: 
Chris@0: remove_prefix_handler :-
Chris@0: 	(   http_current_handler(Path, redirect_prefix(_)),
Chris@0: 	    http_delete_handler(Path),
Chris@0: 	    fail ; true
Chris@0: 	).
Chris@0: 
Chris@0: %%	redirect_prefix(+Prefix, +Request).
Chris@0: %
Chris@0: %	Handle paths below Prefix by removing Prefix and call http_dispatch/1
Chris@0: %	on the result.
Chris@0: 
Chris@0: redirect_prefix(Prefix, Request) :-
Chris@0: 	select(path(Path0), Request, Request1),
Chris@0: 	atom_concat(Prefix, Path1, Path0),
Chris@0: 	atom_concat('/', Path1, Path),
Chris@0: 	debug(http_prefix, 'Redirected ~q --> ~q', [Path0, Path]),
Chris@0: 	http_dispatch([path(Path),x_redirected_path(Path0)|Request1]).
Chris@0: 
Chris@0: :- initialization
Chris@0:    http_setup_prefix_redirect.
Chris@0: 
Chris@0: % allow for dynamic changes of the setting
Chris@0: 
Chris@0: :- listen(settings(changed(http:prefix, _, _)),
Chris@0: 	  http_setup_prefix_redirect).
Chris@0: 
Chris@0: %%	http_current_path(+Request, -Path) is det.
Chris@0: %
Chris@0: %	Get  the  current  location  (path),  even  if  the  prefix  was
Chris@0: %	redirected,
Chris@0: %	
Chris@0: %	@see redirect_prefix/2.
Chris@0: 
Chris@0: http_current_path(Request, Path) :-
Chris@0: 	(   memberchk(x_redirected_path(Path0), Request)
Chris@0: 	->  Path = Path0
Chris@0: 	;   memberchk(path(Path), Request)
Chris@0: 	).