1/*  Part of SWI-Prolog
    2
    3    Author:        Jan Wielemaker
    4    E-mail:        J.Wielemaker@vu.nl
    5    WWW:           http://www.swi-prolog.org
    6    Copyright (c)  2010-2018, University of Amsterdam,
    7                              VU University Amsterdam.
    8    All rights reserved.
    9
   10    Redistribution and use in source and binary forms, with or without
   11    modification, are permitted provided that the following conditions
   12    are met:
   13
   14    1. Redistributions of source code must retain the above copyright
   15       notice, this list of conditions and the following disclaimer.
   16
   17    2. Redistributions in binary form must reproduce the above copyright
   18       notice, this list of conditions and the following disclaimer in
   19       the documentation and/or other materials provided with the
   20       distribution.
   21
   22    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   23    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   24    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   25    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   26    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   27    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   28    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   29    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   30    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   31    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   32    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   33    POSSIBILITY OF SUCH DAMAGE.
   34*/
   35
   36:- module(user_db,
   37          [ set_user_database/1,        % +File
   38
   39            user_add/2,                 % +Name, +Properties
   40            user_del/1,                 % +Name,
   41            set_user_property/2,        % +Name, +Property
   42
   43            openid_add_server/2,        % +Server, +Options
   44            openid_del_server/1,        % +Server
   45            openid_set_property/2,      % +Server, +Property
   46            openid_current_server/1,    % ?Server
   47            openid_server_property/2,   % ?Server, ?Property
   48            openid_server_properties/2, % ?Server, ?Property
   49
   50            user_property/2,            % ?Name, ?Property
   51            check_permission/2,         % +User, +Operation
   52            validate_password/2,        % +User, +Password
   53            password_hash/2,            % +Password, ?Hash
   54
   55            login/1,                    % +User
   56            login/2,                    % +User, +Options
   57            logout/1,                   % +User
   58            current_user/1,             % ?User
   59            logged_on/1,                % -User
   60            logged_on/2,                % -User, +Default
   61            ensure_logged_on/1,         % -User
   62            authorized/1,               % +Action
   63
   64            deny_all_users/1            % +What
   65          ]).   66:- use_module(library(http/http_session)).   67:- use_module(library(http/http_wrapper)).   68:- use_module(library(http/http_openid)).   69:- use_module(library(http/http_authenticate)).   70:- use_module(library(lists)).   71:- use_module(library(broadcast)).   72:- use_module(library(error)).   73:- use_module(library(uri)).   74:- use_module(library(debug)).   75:- use_module(library(persistency)).   76:- use_module(openid).

   91:- dynamic
   92    logged_in/4,                    % Session, User, Time, Options
   93    user/2,                         % Name, Options
   94    denied/1.                       % Deny to all users
   95
   96
   97                 /*******************************
   98                 *        USER DATABASE         *
   99                 *******************************/
  100
  101:- persistent
  102    user(_Name, _UserOptions),
  103    grant_openid_server(_Server, _ServerOptions).

 set_user_database(+File) is det

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

  109set_user_database(File) :-
  110    db_attach(File, [sync(close)]).

 user_add(+Name, +Properties) is det

Add a new user with given properties.

  116user_add(Name, Options) :-
  117    must_be(atom, Name),
  118    assert_user(Name, Options).

 user_del(+Name)

Delete named user from user-database.

  124user_del(Name) :-
  125    must_be(atom, Name),
  126    (   user(Name, _)
  127    ->  retractall_user(Name, _)
  128    ;   existence_error(user, Name)
  129    ).

 set_user_property(+Name, +Property) is det

Replace Property for user Name.

  135set_user_property(Name, Prop) :-
  136    must_be(atom, Name),
  137    (   user(Name, OldProps)
  138    ->  (   memberchk(Prop, OldProps)
  139        ->  true
  140        ;   functor(Prop, PropName, Arity),
  141            functor(Unbound, PropName, Arity),
  142            delete(OldProps, Unbound, NewProps),
  143            retractall_user(Name, _),
  144            assert_user(Name, [Prop|NewProps])
  145        )
  146    ;   existence_error(user, Name)
  147    ).

 openid_add_server(+Server, +Options)

Register an OpenID server.

  154openid_add_server(Server, _Options) :-
  155    openid_current_server(Server),
  156    !,
  157    throw(error(permission_error(create, openid_server, Server),
  158                context(_, 'Already present'))).
  159openid_add_server(Server, Options) :-
  160    assert_grant_openid_server(Server, Options).

 openid_del_server(+Server)

Delete registration of an OpenID server.

  167openid_del_server(Server) :-
  168    retractall_grant_openid_server(Server, _).

 openid_set_property(+Server, +Property) is det

Replace Property for OpenID Server

  175openid_set_property(Server, Prop) :-
  176    must_be(atom, Server),
  177    (   grant_openid_server(Server, OldProps)
  178    ->  (   memberchk(Prop, OldProps)
  179        ->  true
  180        ;   functor(Prop, PropName, Arity),
  181            functor(Unbound, PropName, Arity),
  182            delete(OldProps, Unbound, NewProps),
  183            retractall_grant_openid_server(Server, _),
  184            assert_grant_openid_server(Server, [Prop|NewProps])
  185        )
  186    ;   existence_error(openid_server, Server)
  187    ).

 openid_current_server(?Server) is nondet

  193openid_current_server(Server) :-
  194    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.

  202:- dynamic
  203    registered_server/2.  204
  205openid_server_properties(Server, Properties) :-
  206    (   registered_server(Server, Registered)
  207    ->  grant_openid_server(Registered, Properties)
  208    ;   grant_openid_server(Server, Properties)
  209    ->  true
  210    ;   grant_openid_server(Registered, Properties),
  211        match_server(Server, Registered)
  212    ->  assert(registered_server(Server, Registered))
  213    ;   grant_openid_server(*, Properties)
  214    ).

 match_server(+ServerURL, +RegisteredURL) is semidet

True if ServerURL is in the domain of RegisteredURL.

  220match_server(Server, Registered) :-
  221    uri_host(Server, SHost),
  222    uri_host(Registered, RHost),
  223    atomic_list_concat(SL, '.', SHost),
  224    atomic_list_concat(RL, '.', RHost),
  225    append(_, RL, SL),
  226    !.
  227
  228uri_host(URI, Host) :-
  229    uri_components(URI, CL),
  230    uri_data(authority, CL, Authority),
  231    uri_authority_components(Authority, AC),
  232    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.

  241openid_server_property(Server, Property) :-
  242    openid_server_properties(Server, Properties),
  243    (   var(Property)
  244    ->  member(Property, Properties)
  245    ;   memberchk(Property, Properties)
  246    ).
  247
  248
  249                 /*******************************
  250                 *           USER QUERY         *
  251                 *******************************/

 current_user(?User)

True if User is a registered user.

  257current_user(User) :-
  258    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

  276user_property(User, Property) :-
  277    nonvar(User), nonvar(Property),
  278    !,
  279    uprop(Property, User),
  280    !.
  281user_property(User, Property) :-
  282    uprop(Property, User).
  283
  284uprop(session(SessionID), User) :-
  285    (   nonvar(SessionID)           % speedup
  286    ->  !
  287    ;   true
  288    ),
  289    logged_in(SessionID, User, _, _).
  290uprop(connection(LoginTime, Idle), User) :-
  291    logged_in(SessionID, User, LoginTime, _),
  292    http_current_session(SessionID, idle(Idle)).
  293uprop(url(URL), User) :-
  294    (   http_in_session(SessionID),
  295        logged_in(SessionID, User, _LoginTime, Options)
  296    ->  true
  297    ;   Options = []
  298    ),
  299    user_url(User, URL, Options).
  300uprop(Prop, User) :-
  301    nonvar(User),
  302    !,
  303    (   user(User, Properties)
  304    ->  true
  305    ;   openid_server(User, OpenID, Server),
  306        openid_server_properties(Server, ServerProperties)
  307    ->  Properties = [ type(openid),
  308                       openid(OpenID),
  309                       openid_server(Server)
  310                     | ServerProperties
  311                     ]
  312    ),
  313    (   nonvar(Prop)
  314    ->  memberchk(Prop, Properties)
  315    ;   member(Prop, Properties)
  316    ).
  317uprop(Prop, User) :-
  318    user(User, Properties),
  319    member(Prop, Properties).
  320
  321
  322user_url(User, URL, _) :-
  323    uri_is_global(User),
  324    !,
  325    URL = User.
  326user_url(User, URL, Options) :-
  327    openid_for_local_user(User, URL, Options).
  328
  329
  330                 /*******************************
  331                 *          MISC ROUTINES       *
  332                 *******************************/

 validate_password(+User, +Password)

Validate the password for the given user and password.

  338validate_password(User, Password) :-
  339    user(User, Options),
  340    memberchk(password(Hash), Options),
  341    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.

  349password_hash(Password, Hash) :-
  350    var(Hash),
  351    !,
  352    phrase("$1$", HashString, _),
  353    crypt(Password, HashString),
  354    atom_codes(Hash, HashString).
  355password_hash(Password, Hash) :-
  356    crypt(Password, Hash).
  357
  358
  359                 /*******************************
  360                 *       LOGIN/PERMISSIONS      *
  361                 *******************************/

 logged_on(-User) is semidet

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

  367logged_on(User) :-
  368    http_in_session(SessionID),
  369    user_property(User, session(SessionID)),
  370    !.
  371logged_on(User) :-
  372    http_current_request(Request),
  373    memberchk(authorization(Text), Request),
  374    http_authorization_data(Text, basic(User, Password)),
  375    validate_password(User, Password),
  376    !.

 logged_on(-User, +Default) is det

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

  384logged_on(User, Default) :-
  385    (   logged_on(User0)
  386    ->  User = User0
  387    ;   User = Default
  388    ).

 ensure_logged_on(-User)

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

  396ensure_logged_on(User) :-
  397    http_current_request(Request),
  398    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)

  408authorized(Action) :-
  409    catch(check_permission(anonymous, Action), _, fail),
  410    !.
  411authorized(Action) :-
  412    ensure_logged_on(User),
  413    check_permission(User, Action).

 check_permission(+User, +Operation)

Validate that user is allowed to perform Operation.

Errors

- permission_error(http_location, access, Path)

  422check_permission(User, Operation) :-
  423    \+ denied(User, Operation),
  424    user_property(User, allow(Operations)),
  425    memberchk(Operation, Operations),
  426    !.
  427check_permission(_, _) :-
  428    http_current_request(Request),
  429    memberchk(path(Path), Request),
  430    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,

  438denied(admin, _) :- !, fail.
  439denied(_, Operation) :-
  440    denied(Operation).

 deny_all_users(+Term)

Deny some action to all users. See above.

  447deny_all_users(Term) :-
  448    (   denied(X),
  449        X =@= Term
  450    ->  true
  451    ;   assert(denied(Term))
  452    ).

 login(+User:atom) is det

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

  460login(User) :-
  461    login(User, []).
  462login(User, Options) :-
  463    must_be(atom, User),
  464    get_time(Time),
  465    open_session(Session),
  466    retractall(logged_in(Session, _, _, _)),
  467    asserta(logged_in(Session, User, Time, Options)),
  468    broadcast(cliopatria(login(User, Session))),
  469    debug(login, 'Login user ~w on session ~w', [User, Session]).

 logout(+User) is det

Logout the specified user

  476logout(User) :-
  477    must_be(atom, User),
  478    broadcast(cliopatria(logout(User))),
  479    retractall(logged_in(_Session, User, _Time, _Options)),
  480    debug(login, 'Logout user ~w', [User]).
  481
  482% reclaim login records if a session is closed.
  483
  484:- listen(http_session(end(Session, _Peer)),
  485          ( atom(Session),
  486            retractall(logged_in(Session, _User, _Time, _Options))
  487          )).  488
  489% Use new session management if available.
  490
  491:- http_set_session_options([ create(noauto)
  492                            ]).  493open_session(Session) :-
  494    http_open_session(Session, [])