Chris@0: /*  $Id$
Chris@0: 
Chris@0:     Part of SWI-Prolog
Chris@0: 
Chris@0:     Author:        Jan Wielemaker
Chris@0:     E-mail:        wielemak@scienc.uva.nl
Chris@0:     WWW:           http://www.swi-prolog.org
Chris@0:     Copyright (C): 1985-2007, University of Amsterdam
Chris@0: 
Chris@0:     This program is free software; you can redistribute it and/or
Chris@0:     modify it under the terms of the GNU General Public License
Chris@0:     as published by the Free Software Foundation; either version 2
Chris@0:     of the License, or (at your option) any later version.
Chris@0: 
Chris@0:     This program 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 Lesser General Public
Chris@0:     License along with this library; if not, write to the Free Software
Chris@0:     Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
Chris@0: 
Chris@0:     As a special exception, if you link this library with other files,
Chris@0:     compiled with a Free Software compiler, to produce an executable, this
Chris@0:     library does not by itself cause the resulting executable to be covered
Chris@0:     by the GNU General Public License. This exception does not however
Chris@0:     invalidate any other reasons why the executable file might be covered by
Chris@0:     the GNU General Public License.
Chris@0: */
Chris@0: 
Chris@0: :- module(user_db,
Chris@0: 	  [ set_user_database/1,	% +File
Chris@0: 
Chris@0: 	    user_add/2,			% +Name, +Properties
Chris@0: 	    user_del/1,			% +Name,
Chris@0: 	    set_user_property/2,	% +Name, +Property
Chris@0: 
Chris@0: 	    openid_add_server/2,	% +Server, +Options
Chris@0: 	    openid_del_server/1,	% +Server
Chris@0: 	    openid_set_property/2,	% +Server, +Property
Chris@0: 	    openid_current_server/1,	% ?Server
Chris@0: 	    openid_server_property/2,	% ?Server, ?Property
Chris@0: 	    openid_server_properties/2,	% ?Server, ?Property
Chris@0: 
Chris@0: 	    user_property/2,		% ?Name, ?Property
Chris@0: 	    check_permission/2,		% +User, +Operation
Chris@0: 	    validate_password/2,	% +User, +Password
Chris@0: 	    password_hash/2,		% +Password, ?Hash
Chris@0: 
Chris@0: 	    login/1,			% +User
Chris@0: 	    logout/1,			% +User
Chris@0: 	    current_user/1,		% ?User
Chris@0: 	    logged_on/1,		% -User
Chris@0: 	    ensure_logged_on/1,		% -User
Chris@0: 	    authorized/1,		% +Action
Chris@0: 
Chris@0: 	    deny_all_users/1		% +What
Chris@0: 	  ]).
Chris@0: :- use_module(library('semweb/rdf_db')).
Chris@0: :- use_module(library('http/http_session')).
Chris@0: :- use_module(library('http/http_wrapper')).
Chris@0: :- use_module(library('http/http_openid')).
Chris@0: :- use_module(library(lists)).
Chris@0: :- use_module(library(settings)).
Chris@0: :- use_module(library(error)).
Chris@0: :- use_module(library(url)).
Chris@0: :- use_module(openid).
Chris@0: :- use_module(db).
Chris@0: 
Chris@0: /** <module> User administration
Chris@0: 
Chris@0: Core user administration. The  user  administration   is  based  on  the
Chris@0: following:
Chris@0: 
Chris@0: 	* A persistent fact user/2
Chris@0: 	* A dynamic fact logged_in/3
Chris@0: 	* Session management
Chris@0: 
Chris@0: @tbd	Consider using the RDF database for login.  Maybe requires
Chris@0: 	multiple RDF databases?
Chris@0: 
Chris@0: @author	Jan Wielemaker
Chris@0: */
Chris@0: 
Chris@0: :- dynamic
Chris@0: 	logged_in/3,			% Session, User, Time
Chris@0: 	user/2,				% Name, Options
Chris@0: 	denied/1.			% Deny to all users
Chris@0: 
Chris@0: 
Chris@0: 		 /*******************************
Chris@0: 		 *	  USER DATABASE		*
Chris@0: 		 *******************************/
Chris@0: 
Chris@0: :- db_term
Chris@0: 	user(_Name, _UserOptions),
Chris@0: 	grant_openid_server(_Server, _ServerOptions).
Chris@0: 
Chris@0: %%	set_user_database(+File) is det.
Chris@0: %
Chris@0: %	Load user/2 from File.  Changes are fully synchronous.
Chris@0: 
Chris@0: set_user_database(File) :-
Chris@0: 	db_attach(File, [sync(close)]).
Chris@0: 
Chris@0: %%	user_add(+Name, +Properties) is det.
Chris@0: %
Chris@0: %	Add a new user with given properties.
Chris@0: 
Chris@0: user_add(Name, Options) :-
Chris@0: 	must_be(atom, Name),
Chris@0: 	db_assert(user(Name, Options)).
Chris@0: 
Chris@0: %%	user_del(+Name)
Chris@0: %
Chris@0: %	Delete named user from user-database.
Chris@0: 
Chris@0: user_del(Name) :-
Chris@0: 	must_be(atom, Name),
Chris@0: 	(   user(Name, _)
Chris@0: 	->  db_retractall(user(Name, _))
Chris@0: 	;   existence_error(user, Name)
Chris@0: 	).
Chris@0: 
Chris@0: %%	set_user_property(+Name, +Property) is det.
Chris@0: %
Chris@0: %	Replace Property for user Name.
Chris@0: 
Chris@0: set_user_property(Name, Prop) :-
Chris@0: 	must_be(atom, Name),
Chris@0: 	(   user(Name, OldProps)
Chris@0: 	->  (   memberchk(Prop, OldProps)
Chris@0: 	    ->  true
Chris@0: 	    ;   functor(Prop, PropName, Arity),
Chris@0: 		functor(Unbound, PropName, Arity),
Chris@0: 		delete(OldProps, Unbound, NewProps),
Chris@0: 		db_retractall(user(Name, _)),
Chris@0: 		db_assert(user(Name, [Prop|NewProps]))
Chris@0: 	    )
Chris@0: 	;   existence_error(user, Name)
Chris@0: 	).
Chris@0: 
Chris@0: 
Chris@0: %%	openid_add_server(+Server, +Options)
Chris@0: %
Chris@0: %	Register an OpenID server.
Chris@0: 
Chris@0: openid_add_server(Server, _Options) :-
Chris@0: 	openid_current_server(Server), !,
Chris@0: 	throw(error(permission_error(create, openid_server, Server),
Chris@0: 		    context(_, 'Already present'))).
Chris@0: openid_add_server(Server, Options) :-
Chris@0: 	db_assert(grant_openid_server(Server, Options)).
Chris@0: 
Chris@0: 
Chris@0: %%	openid_del_server(+Server)
Chris@0: %
Chris@0: %	Delete registration of an OpenID server.
Chris@0: 
Chris@0: openid_del_server(Server) :-
Chris@0: 	db_retractall(grant_openid_server(Server, _)).
Chris@0: 
Chris@0: 
Chris@0: %%	openid_set_property(+Server, +Property) is det.
Chris@0: %
Chris@0: %	Replace Property for OpenID Server
Chris@0: 
Chris@0: openid_set_property(Server, Prop) :-
Chris@0: 	must_be(atom, Server),
Chris@0: 	(   grant_openid_server(Server, OldProps)
Chris@0: 	->  (   memberchk(Prop, OldProps)
Chris@0: 	    ->  true
Chris@0: 	    ;   functor(Prop, PropName, Arity),
Chris@0: 		functor(Unbound, PropName, Arity),
Chris@0: 		delete(OldProps, Unbound, NewProps),
Chris@0: 		db_retractall(grant_openid_server(Server, _)),
Chris@0: 		db_assert(grant_openid_server(Server, [Prop|NewProps]))
Chris@0: 	    )
Chris@0: 	;   existence_error(openid_server, Server)
Chris@0: 	).
Chris@0: 
Chris@0: 
Chris@0: %%	openid_current_server(?Server) is nondet.
Chris@0: %
Chris@0: 
Chris@0: openid_current_server(Server) :-
Chris@0: 	grant_openid_server(Server, _).
Chris@0: 
Chris@0: %%	openid_server_properties(+Server, -Properties) is semidet.
Chris@0: %
Chris@0: %	Try find properties for the given server. Note that we generally
Chris@0: %	refer to a server using its domain.  The actjual server may be a
Chris@0: %	path on the server or a machine in the domain.
Chris@0: 
Chris@0: :- dynamic
Chris@0: 	registered_server/2.
Chris@0: 
Chris@0: openid_server_properties(Server, Properties) :-
Chris@0: 	(   registered_server(Server, Registered)
Chris@0: 	->  grant_openid_server(Registered, Properties)
Chris@0: 	;   grant_openid_server(Server, Properties)
Chris@0: 	->  true
Chris@0: 	;   grant_openid_server(Registered, Properties),
Chris@0: 	    match_server(Server, Registered)
Chris@0: 	->  assert(registered_server(Server, Registered))
Chris@0: 	;   grant_openid_server(*, Properties)
Chris@0: 	).
Chris@0: 
Chris@0: %%	match_server(+ServerURL, +RegisteredURL) is semidet.
Chris@0: %
Chris@0: %	True if ServerURL is in the domain of RegisteredURL.
Chris@0: 
Chris@0: match_server(Server, Registered) :-
Chris@0: 	parse_url(Server, SParts),
Chris@0: 	memberchk(host(SHost), SParts),
Chris@0: 	parse_url(Registered, RParts),	
Chris@0: 	memberchk(host(RHost), RParts),
Chris@0: 	concat_atom(SL, '.', SHost),
Chris@0: 	concat_atom(RL, '.', RHost),
Chris@0: 	append(_, RL, SL), !.
Chris@0: 
Chris@0: 
Chris@0: openid_server_property(Server, Property) :-
Chris@0: 	openid_server_properties(Server, Properties),
Chris@0: 	(   var(Property)
Chris@0: 	->  member(Property, Properties)
Chris@0: 	;   memberchk(Property, Properties)
Chris@0: 	).
Chris@0: 
Chris@0: 
Chris@0: 		 /*******************************
Chris@0: 		 *	     USER QUERY         *
Chris@0: 		 *******************************/
Chris@0: 
Chris@0: %%	current_user(?User)
Chris@0: %	
Chris@0: %	True if User is a registered user.
Chris@0: 
Chris@0: current_user(User) :-
Chris@0: 	user(User, _).
Chris@0: 
Chris@0: %%	user_property(?User, ?Property) is nondet.
Chris@0: %%	user_property(+User, +Property) is semidet.
Chris@0: %	
Chris@0: %	True if Property is a defined property on User.  In addition to
Chris@0: %	properties explicitely stored with users, we define:
Chris@0: %	
Chris@0: %		* session(SessionID)
Chris@0: %		* connection(LoginTime, Idle)
Chris@0: %		* url(URL)
Chris@0: %		Generates reference to our own OpenID server for local
Chris@0: %		login
Chris@0: %		* openid(OpenID)
Chris@0: %		Refers to the official OpenID (possibly delegated)
Chris@0: %		* openid_server(Server)
Chris@0: %		Refers to the OpenID server that validated the login
Chris@0: 
Chris@0: user_property(User, Property) :-
Chris@0: 	nonvar(User), nonvar(Property), !,
Chris@0: 	uprop(Property, User), !.
Chris@0: user_property(User, Property) :-
Chris@0: 	uprop(Property, User).
Chris@0: 
Chris@0: uprop(session(SessionID), User) :-
Chris@0: 	(   nonvar(SessionID)		% speedup
Chris@0: 	->  !
Chris@0: 	;   true
Chris@0: 	),
Chris@0: 	logged_in(SessionID, User, _).
Chris@0: uprop(connection(LoginTime, Idle), User) :-
Chris@0: 	logged_in(SessionID, User, LoginTime),
Chris@0: 	http_current_session(SessionID, idle(Idle)).
Chris@0: uprop(url(URL), User) :-
Chris@0: 	user_url(User, URL).
Chris@0: uprop(Prop, User) :-
Chris@0: 	nonvar(User), !,
Chris@0: 	(   user(User, Properties)
Chris@0: 	->  true
Chris@0: 	;   openid_server(User, OpenID, Server),
Chris@0: 	    openid_server_properties(Server, Properties0)
Chris@0: 	->  Properties = [type(openid),openid(OpenID),openid_server(Server)|Properties0]
Chris@0: 	),
Chris@0: 	(   nonvar(Prop)
Chris@0: 	->  memberchk(Prop, Properties)
Chris@0: 	;   member(Prop, Properties)
Chris@0: 	).
Chris@0: uprop(Prop, User) :-
Chris@0: 	user(User, Properties),
Chris@0: 	member(Prop, Properties).
Chris@0: 
Chris@0: 
Chris@0: user_url(User, URL) :-
Chris@0: 	is_absolute_url(User), !,
Chris@0: 	URL = User.
Chris@0: user_url(User, URL) :-
Chris@0: 	openid_for_local_user(User, URL).
Chris@0: 
Chris@0: 
Chris@0: 		 /*******************************
Chris@0: 		 *	    MISC ROUTINES	*
Chris@0: 		 *******************************/
Chris@0: 
Chris@0: %%	validate_password(+User, +Password)
Chris@0: %	
Chris@0: %	Validate the password for the given user and password.
Chris@0: 
Chris@0: validate_password(User, Password) :-
Chris@0: 	user(User, Options),
Chris@0: 	memberchk(password(Hash), Options),
Chris@0: 	password_hash(Password, Hash).
Chris@0: 
Chris@0: 
Chris@0: %%	password_hash(+Password, ?Hash)
Chris@0: %	
Chris@0: %	Generate a hash from a password  or   test  a password against a
Chris@0: %	hash. Like Unix we add a random   2 character prefix to make the
Chris@0: %	same password return different  hashes   and  thus obscure equal
Chris@0: %	passwords.
Chris@0: %	
Chris@0: %	@tbd	Use crypt/2 from library(crypt)
Chris@0: 
Chris@0: password_hash(Password, Hash) :-
Chris@0: 	var(Hash), !,
Chris@0: 	C1 is random(0'z-0'a) + 0'a,
Chris@0: 	C2 is random(0'z-0'a) + 0'a,
Chris@0: 	atom_codes(Password, Codes),
Chris@0: 	rdf_atom_md5([C1,C2|Codes], 100000, Hash0),
Chris@0: 	atom_codes(Prefix, [C1, C2]),
Chris@0: 	atom_concat(Prefix, Hash0, Hash).
Chris@0: password_hash(Password, Hash) :-
Chris@0: 	sub_atom(Hash, 0, 2, _, Prefix),
Chris@0: 	sub_atom(Hash, 2, _, 0, Hash0),
Chris@0: 	atom_codes(Prefix, [C1, C2]),
Chris@0: 	atom_codes(Password, Codes),
Chris@0: 	rdf_atom_md5([C1,C2|Codes], 100000, Hash0).
Chris@0: 
Chris@0: 
Chris@0: 		 /*******************************
Chris@0: 		 *	 LOGIN/PERMISSIONS	*
Chris@0: 		 *******************************/
Chris@0: 
Chris@0: %%	logged_on(-User) is det.
Chris@0: %
Chris@0: %	True if User is the name of the currently logged in user.
Chris@0: %
Chris@0: %	@error	context_error(not_logged_in)
Chris@0: 
Chris@0: logged_on(User) :-
Chris@0: 	http_session_id(SessionID),
Chris@0: 	user_property(User, session(SessionID)), !.
Chris@0: logged_on(_) :-
Chris@0: 	throw(error(context_error(not_logged_in), _)).
Chris@0: 
Chris@0: %%	ensure_logged_on(-User)
Chris@0: %
Chris@0: %	Make sure we are logged in and return the current user.
Chris@0: %	See openid_user/3 for details.
Chris@0: 
Chris@0: ensure_logged_on(User) :-
Chris@0: 	http_current_request(Request),
Chris@0: 	(   catch(setting(http:prefix, Prefix), _, fail)
Chris@0: 	->  atom_concat(Prefix, '/openid/login', LoginURL),
Chris@0: 	    openid_user(Request, User, [login_url(LoginURL)])
Chris@0: 	;   openid_user(Request, User, [])
Chris@0: 	).
Chris@0: 
Chris@0: 
Chris@0: %%	authorized(+Action) is det.
Chris@0: %
Chris@0: %	validate the current user is allowed to perform Action.  Throws
Chris@0: %	a permission error if this is not the case.  Never fails.
Chris@0: %
Chris@0: %	@error	permission_error(http_location, access, Path)
Chris@0: 
Chris@0: authorized(Action) :-
Chris@0: 	catch(check_permission(anonymous, Action), _, fail), !.
Chris@0: authorized(Action) :-
Chris@0: 	ensure_logged_on(User),
Chris@0: 	check_permission(User, Action).
Chris@0: 
Chris@0: 
Chris@0: %%	check_permission(+User, +Operation)
Chris@0: %	
Chris@0: %	Validate that user is allowed to perform Operation.
Chris@0: %	
Chris@0: %	@error	permission_error(http_location, access, Path)
Chris@0: 
Chris@0: check_permission(User, Operation) :-
Chris@0: 	\+ denied(User, Operation),
Chris@0: 	user_property(User, allow(Operations)),
Chris@0: 	memberchk(Operation, Operations), !.
Chris@0: check_permission(_, _) :-
Chris@0: 	http_current_request(Request),
Chris@0: 	memberchk(path(Path), Request),
Chris@0: 	permission_error(http_location, access, Path).
Chris@0: 
Chris@0: %%	denied(+User, +Operation)
Chris@0: %	
Chris@0: %	Deny actions to all users but admin.  This is a bit of a quick
Chris@0: %	hack to avoid loosing data in a multi-user experiment.  Do not
Chris@0: %	yet rely on this,
Chris@0: 
Chris@0: denied(admin, _) :- !, fail.
Chris@0: denied(_, Operation) :-
Chris@0: 	denied(Operation).
Chris@0: 
Chris@0: 
Chris@0: %%	deny_all_users(+Term)
Chris@0: %	
Chris@0: %	Deny some action to all users.  See above.
Chris@0: 
Chris@0: deny_all_users(Term) :-
Chris@0: 	(   denied(X),
Chris@0: 	    X =@= Term
Chris@0: 	->  true
Chris@0: 	;   assert(denied(Term))
Chris@0: 	).
Chris@0: 
Chris@0: 
Chris@0: %%	login(+User:atom)
Chris@0: %	
Chris@0: %	Accept user as a user that has logged on into the current
Chris@0: %	session.
Chris@0: 
Chris@0: login(User) :-
Chris@0: 	must_be(atom, User),
Chris@0: 	get_time(Time),
Chris@0: 	http_session_id(Session),
Chris@0: 	retractall(logged_in(_, Session, _)),
Chris@0: 	assert(logged_in(Session, User, Time)).
Chris@0: 
Chris@0: %%	logout(+User)
Chris@0: %	
Chris@0: %	Logout the specified user
Chris@0: 
Chris@0: logout(User) :-
Chris@0: 	must_be(atom, User),
Chris@0: 	retractall(logged_in(_Session, User, _Time)).