1/*  $Id$
   2
   3    Part of SWI-Prolog
   4
   5    Author:        Jan Wielemaker
   6    E-mail:        J.Wielemaker@cs.vu.nl
   7    WWW:           http://www.swi-prolog.org
   8    Copyright (C): 2007-2010, University of Amsterdam,
   9			      VU University Amsterdam.
  10
  11    This program is free software; you can redistribute it and/or
  12    modify it under the terms of the GNU General Public License
  13    as published by the Free Software Foundation; either version 2
  14    of the License, or (at your option) any later version.
  15
  16    This program is distributed in the hope that it will be useful,
  17    but WITHOUT ANY WARRANTY; without even the implied warranty of
  18    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19    GNU General Public License for more details.
  20
  21    You should have received a copy of the GNU Lesser General Public
  22    License along with this library; if not, write to the Free Software
  23    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  24
  25    As a special exception, if you link this library with other files,
  26    compiled with a Free Software compiler, to produce an executable, this
  27    library does not by itself cause the resulting executable to be covered
  28    by the GNU General Public License. This exception does not however
  29    invalidate any other reasons why the executable file might be covered by
  30    the GNU General Public License.
  31*/
  32
  33:- module(user_db,
  34	  [ set_user_database/1,	% +File
  35
  36	    user_add/2,			% +Name, +Properties
  37	    user_del/1,			% +Name,
  38	    set_user_property/2,	% +Name, +Property
  39
  40	    openid_add_server/2,	% +Server, +Options
  41	    openid_del_server/1,	% +Server
  42	    openid_set_property/2,	% +Server, +Property
  43	    openid_current_server/1,	% ?Server
  44	    openid_server_property/2,	% ?Server, ?Property
  45	    openid_server_properties/2,	% ?Server, ?Property
  46
  47	    user_property/2,		% ?Name, ?Property
  48	    check_permission/2,		% +User, +Operation
  49	    validate_password/2,	% +User, +Password
  50	    password_hash/2,		% +Password, ?Hash
  51
  52	    login/1,			% +User
  53	    logout/1,			% +User
  54	    current_user/1,		% ?User
  55	    logged_on/1,		% -User
  56	    logged_on/2,		% -User, +Default
  57	    ensure_logged_on/1,		% -User
  58	    authorized/1,		% +Action
  59
  60	    deny_all_users/1		% +What
  61	  ]).
  62:- use_module(library(http/http_session)).
  63:- use_module(library(http/http_wrapper)).
  64:- use_module(library(http/http_openid)).
  65:- use_module(library(http/http_authenticate)).
  66:- use_module(library(lists)).
  67:- use_module(library(broadcast)).
  68:- use_module(library(error)).
  69:- use_module(library(uri)).
  70:- use_module(library(debug)).
  71:- use_module(library(persistency)).
  72:- use_module(openid).
  73
  74/** <module> User administration
  75
  76Core user administration. The  user  administration   is  based  on  the
  77following:
  78
  79	* A persistent fact user/2
  80	* A dynamic fact logged_in/3
  81	* Session management
  82
  83@see	preferences.pl implements user preferences
  84@see	openid.pl implements OpenID server and client
  85*/
  86
  87:- dynamic
  88	logged_in/3,			% Session, User, Time
  89	user/2,				% Name, Options
  90	denied/1.			% Deny to all users
  91
  92
  93		 /*******************************
  94		 *	  USER DATABASE		*
  95		 *******************************/
  96
  97:- persistent
  98	user(_Name, _UserOptions),
  99	grant_openid_server(_Server, _ServerOptions).
 100
 101%%	set_user_database(+File) is det.
 102%
 103%	Load user/2 from File.  Changes are fully synchronous.
 104
 105set_user_database(File) :-
 106	db_attach(File, [sync(close)]).
 107
 108%%	user_add(+Name, +Properties) is det.
 109%
 110%	Add a new user with given properties.
 111
 112user_add(Name, Options) :-
 113	must_be(atom, Name),
 114	assert_user(Name, Options).
 115
 116%%	user_del(+Name)
 117%
 118%	Delete named user from user-database.
 119
 120user_del(Name) :-
 121	must_be(atom, Name),
 122	(   user(Name, _)
 123	->  retractall_user(Name, _)
 124	;   existence_error(user, Name)
 125	).
 126
 127%%	set_user_property(+Name, +Property) is det.
 128%
 129%	Replace Property for user Name.
 130
 131set_user_property(Name, Prop) :-
 132	must_be(atom, Name),
 133	(   user(Name, OldProps)
 134	->  (   memberchk(Prop, OldProps)
 135	    ->  true
 136	    ;   functor(Prop, PropName, Arity),
 137		functor(Unbound, PropName, Arity),
 138		delete(OldProps, Unbound, NewProps),
 139		retractall_user(Name, _),
 140		assert_user(Name, [Prop|NewProps])
 141	    )
 142	;   existence_error(user, Name)
 143	).
 144
 145
 146%%	openid_add_server(+Server, +Options)
 147%
 148%	Register an OpenID server.
 149
 150openid_add_server(Server, _Options) :-
 151	openid_current_server(Server), !,
 152	throw(error(permission_error(create, openid_server, Server),
 153		    context(_, 'Already present'))).
 154openid_add_server(Server, Options) :-
 155	assert_grant_openid_server(Server, Options).
 156
 157
 158%%	openid_del_server(+Server)
 159%
 160%	Delete registration of an OpenID server.
 161
 162openid_del_server(Server) :-
 163	retractall_grant_openid_server(Server, _).
 164
 165
 166%%	openid_set_property(+Server, +Property) is det.
 167%
 168%	Replace Property for OpenID Server
 169
 170openid_set_property(Server, Prop) :-
 171	must_be(atom, Server),
 172	(   grant_openid_server(Server, OldProps)
 173	->  (   memberchk(Prop, OldProps)
 174	    ->  true
 175	    ;   functor(Prop, PropName, Arity),
 176		functor(Unbound, PropName, Arity),
 177		delete(OldProps, Unbound, NewProps),
 178		retractall_grant_openid_server(Server, _),
 179		assert_grant_openid_server(Server, [Prop|NewProps])
 180	    )
 181	;   existence_error(openid_server, Server)
 182	).
 183
 184
 185%%	openid_current_server(?Server) is nondet.
 186%
 187
 188openid_current_server(Server) :-
 189	grant_openid_server(Server, _).
 190
 191%%	openid_server_properties(+Server, -Properties) is semidet.
 192%
 193%	Try find properties for the given server. Note that we generally
 194%	refer to a server using its domain.   The actual server may be a
 195%	path on the server or a machine in the domain.
 196
 197:- dynamic
 198	registered_server/2.
 199
 200openid_server_properties(Server, Properties) :-
 201	(   registered_server(Server, Registered)
 202	->  grant_openid_server(Registered, Properties)
 203	;   grant_openid_server(Server, Properties)
 204	->  true
 205	;   grant_openid_server(Registered, Properties),
 206	    match_server(Server, Registered)
 207	->  assert(registered_server(Server, Registered))
 208	;   grant_openid_server(*, Properties)
 209	).
 210
 211%%	match_server(+ServerURL, +RegisteredURL) is semidet.
 212%
 213%	True if ServerURL is in the domain of RegisteredURL.
 214
 215match_server(Server, Registered) :-
 216	uri_host(Server, SHost),
 217	uri_host(Registered, RHost),
 218	atomic_list_concat(SL, '.', SHost),
 219	atomic_list_concat(RL, '.', RHost),
 220	append(_, RL, SL), !.
 221
 222uri_host(URI, Host) :-
 223	uri_components(URI, CL),
 224	uri_data(authority, CL, Authority),
 225	uri_authority_components(Authority, AC),
 226	uri_authority_data(host, AC, Host).
 227
 228%%	openid_server_property(+Server, +Property) is semidet.
 229%%	openid_server_property(+Server, -Property) is nondet.
 230%
 231%	True if OpenID Server has Property.
 232%
 233%	@see openid_server_properties/2.
 234
 235openid_server_property(Server, Property) :-
 236	openid_server_properties(Server, Properties),
 237	(   var(Property)
 238	->  member(Property, Properties)
 239	;   memberchk(Property, Properties)
 240	).
 241
 242
 243		 /*******************************
 244		 *	     USER QUERY         *
 245		 *******************************/
 246
 247%%	current_user(?User)
 248%
 249%	True if User is a registered user.
 250
 251current_user(User) :-
 252	user(User, _).
 253
 254%%	user_property(?User, ?Property) is nondet.
 255%%	user_property(+User, +Property) is semidet.
 256%
 257%	True if Property is a defined property on User.  In addition to
 258%	properties explicitely stored with users, we define:
 259%
 260%		* session(SessionID)
 261%		* connection(LoginTime, Idle)
 262%		* url(URL)
 263%		Generates reference to our own OpenID server for local
 264%		login
 265%		* openid(OpenID)
 266%		Refers to the official OpenID (possibly delegated)
 267%		* openid_server(Server)
 268%		Refers to the OpenID server that validated the login
 269
 270user_property(User, Property) :-
 271	nonvar(User), nonvar(Property), !,
 272	uprop(Property, User), !.
 273user_property(User, Property) :-
 274	uprop(Property, User).
 275
 276uprop(session(SessionID), User) :-
 277	(   nonvar(SessionID)		% speedup
 278	->  !
 279	;   true
 280	),
 281	logged_in(SessionID, User, _).
 282uprop(connection(LoginTime, Idle), User) :-
 283	logged_in(SessionID, User, LoginTime),
 284	http_current_session(SessionID, idle(Idle)).
 285uprop(url(URL), User) :-
 286	user_url(User, URL).
 287uprop(Prop, User) :-
 288	nonvar(User), !,
 289	(   user(User, Properties)
 290	->  true
 291	;   openid_server(User, OpenID, Server),
 292	    openid_server_properties(Server, ServerProperties)
 293	->  Properties = [ type(openid),
 294			   openid(OpenID),
 295			   openid_server(Server)
 296			 | ServerProperties
 297			 ]
 298	),
 299	(   nonvar(Prop)
 300	->  memberchk(Prop, Properties)
 301	;   member(Prop, Properties)
 302	).
 303uprop(Prop, User) :-
 304	user(User, Properties),
 305	member(Prop, Properties).
 306
 307
 308user_url(User, URL) :-
 309	uri_is_global(User), !,
 310	URL = User.
 311user_url(User, URL) :-
 312	openid_for_local_user(User, URL).
 313
 314
 315		 /*******************************
 316		 *	    MISC ROUTINES	*
 317		 *******************************/
 318
 319%%	validate_password(+User, +Password)
 320%
 321%	Validate the password for the given user and password.
 322
 323validate_password(User, Password) :-
 324	user(User, Options),
 325	memberchk(password(Hash), Options),
 326	password_hash(Password, Hash).
 327
 328
 329%%	password_hash(+Password, ?Hash)
 330%
 331%	Generate a hash from a password  or   test  a password against a
 332%	hash. Uses crypt/2. The default hashing is Unix-compatible MD5.
 333
 334password_hash(Password, Hash) :-
 335	var(Hash), !,
 336	phrase("$1$", HashString, _),
 337	crypt(Password, HashString),
 338	atom_codes(Hash, HashString).
 339password_hash(Password, Hash) :-
 340	crypt(Password, Hash).
 341
 342
 343		 /*******************************
 344		 *	 LOGIN/PERMISSIONS	*
 345		 *******************************/
 346
 347%%	logged_on(-User) is semidet.
 348%
 349%	True if User is the name of the currently logged in user.
 350
 351logged_on(User) :-
 352	http_in_session(SessionID),
 353	user_property(User, session(SessionID)), !.
 354logged_on(User) :-
 355	http_current_request(Request),
 356	memberchk(authorization(Text), Request),
 357	http_authorization_data(Text, basic(User, Password)),
 358	validate_password(User, Password), !.
 359
 360
 361%%	logged_on(-User, +Default) is det.
 362%
 363%	Get the current user or  unify   User  with  Default. Typically,
 364%	Default is =anonymous=.
 365
 366logged_on(User, Default) :-
 367	(   logged_on(User0)
 368	->  User = User0
 369	;   User = Default
 370	).
 371
 372
 373%%	ensure_logged_on(-User)
 374%
 375%	Make sure we are logged in and return the current user.
 376%	See openid_user/3 for details.
 377
 378ensure_logged_on(User) :-
 379	http_current_request(Request),
 380	openid_user(Request, User, []).
 381
 382
 383%%	authorized(+Action) is det.
 384%
 385%	validate the current user is allowed to perform Action.  Throws
 386%	a permission error if this is not the case.  Never fails.
 387%
 388%	@error	permission_error(http_location, access, Path)
 389
 390authorized(Action) :-
 391	catch(check_permission(anonymous, Action), _, fail), !.
 392authorized(Action) :-
 393	ensure_logged_on(User),
 394	check_permission(User, Action).
 395
 396
 397%%	check_permission(+User, +Operation)
 398%
 399%	Validate that user is allowed to perform Operation.
 400%
 401%	@error	permission_error(http_location, access, Path)
 402
 403check_permission(User, Operation) :-
 404	\+ denied(User, Operation),
 405	user_property(User, allow(Operations)),
 406	memberchk(Operation, Operations), !.
 407check_permission(_, _) :-
 408	http_current_request(Request),
 409	memberchk(path(Path), Request),
 410	permission_error(http_location, access, Path).
 411
 412%%	denied(+User, +Operation)
 413%
 414%	Deny actions to all users but admin.  This is a bit of a quick
 415%	hack to avoid loosing data in a multi-user experiment.  Do not
 416%	yet rely on this,
 417
 418denied(admin, _) :- !, fail.
 419denied(_, Operation) :-
 420	denied(Operation).
 421
 422
 423%%	deny_all_users(+Term)
 424%
 425%	Deny some action to all users.  See above.
 426
 427deny_all_users(Term) :-
 428	(   denied(X),
 429	    X =@= Term
 430	->  true
 431	;   assert(denied(Term))
 432	).
 433
 434
 435%%	login(+User:atom) is det.
 436%
 437%	Accept user as a user that has logged on into the current
 438%	session.
 439
 440login(User) :-
 441	must_be(atom, User),
 442	get_time(Time),
 443	open_session(Session),
 444	retractall(logged_in(Session, _, _)),
 445	asserta(logged_in(Session, User, Time)),
 446	broadcast(cliopatria(login(User, Session))),
 447	debug(login, 'Login user ~w on session ~w', [User, Session]).
 448
 449
 450%%	logout(+User) is det.
 451%
 452%	Logout the specified user
 453
 454logout(User) :-
 455	must_be(atom, User),
 456	broadcast(cliopatria(logout(User))),
 457	retractall(logged_in(_Session, User, _Time)),
 458	debug(login, 'Logout user ~w', [User]).
 459
 460% reclaim login records if a session is closed.
 461
 462:- listen(http_session(end(Session, _Peer)),
 463	  ( atom(Session),
 464	    retractall(logged_in(Session, _User, _Time))
 465	  )).
 466
 467% Use new session management if available.
 468
 469:- http_set_session_options([ create(noauto)
 470			    ]).
 471open_session(Session) :-
 472	http_open_session(Session, []).