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