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).

   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).

 set_user_database(+File) is det

Load user/2 from File. Changes are fully synchronous.

  104set_user_database(File) :-
  105	db_attach(File, [sync(close)]).

 user_add(+Name, +Properties) is det

Add a new user with given properties.

  111user_add(Name, Options) :-
  112	must_be(atom, Name),
  113	assert_user(Name, Options).

 user_del(+Name)

Delete named user from user-database.

  119user_del(Name) :-
  120	must_be(atom, Name),
  121	(   user(Name, _)
  122	->  retractall_user(Name, _)
  123	;   existence_error(user, Name)
  124	).

 set_user_property(+Name, +Property) is det

Replace Property for user Name.

  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	).

 openid_add_server(+Server, +Options)

Register an OpenID server.

  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).

 openid_del_server(+Server)

Delete registration of an OpenID server.

  161openid_del_server(Server) :-
  162	retractall_grant_openid_server(Server, _).

 openid_set_property(+Server, +Property) is det

Replace Property for OpenID Server

  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	).

 openid_current_server(?Server) is nondet

  187openid_current_server(Server) :-
  188	grant_openid_server(Server, _).

 openid_server_properties(+Server, -Properties) is semidet

Try find properties for the given server. Note that we generally refer to a server using its domain. The actual server may be a path on the server or a machine in the domain.

  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	).

 match_server(+ServerURL, +RegisteredURL) is semidet

True if ServerURL is in the domain of RegisteredURL.

  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).

 openid_server_property(+Server, +Property) is semidet

openid_server_property(+Server, -Property) is nondet

True if OpenID Server has Property.

See also

- openid_server_properties/2.

  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		 *******************************/

 current_user(?User)

True if User is a registered user.

  250current_user(User) :-
  251	user(User, _).

 user_property(?User, ?Property) is nondet

user_property(+User, +Property) is semidet

True if Property is a defined property on User. In addition to properties explicitely stored with users, we define:

session(SessionID)

connection(LoginTime, Idle)

url(URL)

Generates reference to our own OpenID server for local login

openid(OpenID)

Refers to the official OpenID (possibly delegated)

openid_server(Server)

Refers to the OpenID server that validated the login

  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		 *******************************/

 validate_password(+User, +Password)

Validate the password for the given user and password.

  327validate_password(User, Password) :-
  328	user(User, Options),
  329	memberchk(password(Hash), Options),
  330	password_hash(Password, Hash).

 password_hash(+Password, ?Hash)

Generate a hash from a password or test a password against a hash. Uses crypt/2. The default hashing is Unix-compatible MD5.

  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		 *******************************/

 logged_on(-User) is semidet

True if User is the name of the currently logged in user.

  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), !.

 logged_on(-User, +Default) is det

Get the current user or unify User with Default. Typically, Default is anonymous.

  370logged_on(User, Default) :-
  371	(   logged_on(User0)
  372	->  User = User0
  373	;   User = Default
  374	).

 ensure_logged_on(-User)

Make sure we are logged in and return the current user. See openid_user/3 for details.

  382ensure_logged_on(User) :-
  383	http_current_request(Request),
  384	openid_user(Request, User, []).

 authorized(+Action) is det

validate the current user is allowed to perform Action. Throws a permission error if this is not the case. Never fails.

Errors

- permission_error(http_location, access, Path)

  394authorized(Action) :-
  395	catch(check_permission(anonymous, Action), _, fail), !.
  396authorized(Action) :-
  397	ensure_logged_on(User),
  398	check_permission(User, Action).

 check_permission(+User, +Operation)

Validate that user is allowed to perform Operation.

Errors

- permission_error(http_location, access, Path)

  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).

 denied(+User, +Operation)

Deny actions to all users but admin. This is a bit of a quick hack to avoid loosing data in a multi-user experiment. Do not yet rely on this,

  422denied(admin, _) :- !, fail.
  423denied(_, Operation) :-
  424	denied(Operation).

 deny_all_users(+Term)

Deny some action to all users. See above.

  431deny_all_users(Term) :-
  432	(   denied(X),
  433	    X =@= Term
  434	->  true
  435	;   assert(denied(Term))
  436	).

 login(+User:atom) is det

Accept user as a user that has logged on into the current session.

  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]).

 logout(+User) is det

Logout the specified user

  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, [])