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).   77
   78/** <module> User administration
   79
   80Core user administration. The  user  administration   is  based  on  the
   81following:
   82
   83        * A persistent fact user/2
   84        * A dynamic fact logged_in/4
   85        * Session management
   86
   87@see    preferences.pl implements user preferences
   88@see    openid.pl implements OpenID server and client
   89*/
   90
   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).  104
  105%!  set_user_database(+File) is det.
  106%
  107%   Load user/2 from File.  Changes are fully synchronous.
  108
  109set_user_database(File) :-
  110    db_attach(File, [sync(close)]).
  111
  112%!  user_add(+Name, +Properties) is det.
  113%
  114%   Add a new user with given properties.
  115
  116user_add(Name, Options) :-
  117    must_be(atom, Name),
  118    assert_user(Name, Options).
  119
  120%!  user_del(+Name)
  121%
  122%   Delete named user from user-database.
  123
  124user_del(Name) :-
  125    must_be(atom, Name),
  126    (   user(Name, _)
  127    ->  retractall_user(Name, _)
  128    ;   existence_error(user, Name)
  129    ).
  130
  131%!  set_user_property(+Name, +Property) is det.
  132%
  133%   Replace Property for user Name.
  134
  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    ).
  148
  149
  150%!  openid_add_server(+Server, +Options)
  151%
  152%   Register an OpenID server.
  153
  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).
  161
  162
  163%!  openid_del_server(+Server)
  164%
  165%   Delete registration of an OpenID server.
  166
  167openid_del_server(Server) :-
  168    retractall_grant_openid_server(Server, _).
  169
  170
  171%!  openid_set_property(+Server, +Property) is det.
  172%
  173%   Replace Property for OpenID Server
  174
  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    ).
  188
  189
  190%!  openid_current_server(?Server) is nondet.
  191%
  192
  193openid_current_server(Server) :-
  194    grant_openid_server(Server, _).
  195
  196%!  openid_server_properties(+Server, -Properties) is semidet.
  197%
  198%   Try find properties for the given server. Note that we generally
  199%   refer to a server using its domain.   The actual server may be a
  200%   path on the server or a machine in the domain.
  201
  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    ).
  215
  216%!  match_server(+ServerURL, +RegisteredURL) is semidet.
  217%
  218%   True if ServerURL is in the domain of RegisteredURL.
  219
  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).
  233
  234%!  openid_server_property(+Server, +Property) is semidet.
  235%!  openid_server_property(+Server, -Property) is nondet.
  236%
  237%   True if OpenID Server has Property.
  238%
  239%   @see openid_server_properties/2.
  240
  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                 *******************************/
  252
  253%!  current_user(?User)
  254%
  255%   True if User is a registered user.
  256
  257current_user(User) :-
  258    user(User, _).
  259
  260%!  user_property(?User, ?Property) is nondet.
  261%!  user_property(+User, +Property) is semidet.
  262%
  263%   True if Property is a defined property on User.  In addition to
  264%   properties explicitely stored with users, we define:
  265%
  266%           * session(SessionID)
  267%           * connection(LoginTime, Idle)
  268%           * url(URL)
  269%           Generates reference to our own OpenID server for local
  270%           login
  271%           * openid(OpenID)
  272%           Refers to the official OpenID (possibly delegated)
  273%           * openid_server(Server)
  274%           Refers to the OpenID server that validated the login
  275
  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                 *******************************/
  333
  334%!  validate_password(+User, +Password)
  335%
  336%   Validate the password for the given user and password.
  337
  338validate_password(User, Password) :-
  339    user(User, Options),
  340    memberchk(password(Hash), Options),
  341    password_hash(Password, Hash).
  342
  343
  344%!  password_hash(+Password, ?Hash)
  345%
  346%   Generate a hash from a password  or   test  a password against a
  347%   hash. Uses crypt/2. The default hashing is Unix-compatible MD5.
  348
  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                 *******************************/
  362
  363%!  logged_on(-User) is semidet.
  364%
  365%   True if User is the name of the currently logged in user.
  366
  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    !.
  377
  378
  379%!  logged_on(-User, +Default) is det.
  380%
  381%   Get the current user or  unify   User  with  Default. Typically,
  382%   Default is =anonymous=.
  383
  384logged_on(User, Default) :-
  385    (   logged_on(User0)
  386    ->  User = User0
  387    ;   User = Default
  388    ).
  389
  390
  391%!  ensure_logged_on(-User)
  392%
  393%   Make sure we are logged in and return the current user.
  394%   See openid_user/3 for details.
  395
  396ensure_logged_on(User) :-
  397    http_current_request(Request),
  398    openid_user(Request, User, []).
  399
  400
  401%!  authorized(+Action) is det.
  402%
  403%   validate the current user is allowed to perform Action.  Throws
  404%   a permission error if this is not the case.  Never fails.
  405%
  406%   @error  permission_error(http_location, access, Path)
  407
  408authorized(Action) :-
  409    catch(check_permission(anonymous, Action), _, fail),
  410    !.
  411authorized(Action) :-
  412    ensure_logged_on(User),
  413    check_permission(User, Action).
  414
  415
  416%!  check_permission(+User, +Operation)
  417%
  418%   Validate that user is allowed to perform Operation.
  419%
  420%   @error  permission_error(http_location, access, Path)
  421
  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).
  431
  432%!  denied(+User, +Operation)
  433%
  434%   Deny actions to all users but admin.  This is a bit of a quick
  435%   hack to avoid loosing data in a multi-user experiment.  Do not
  436%   yet rely on this,
  437
  438denied(admin, _) :- !, fail.
  439denied(_, Operation) :-
  440    denied(Operation).
  441
  442
  443%!  deny_all_users(+Term)
  444%
  445%   Deny some action to all users.  See above.
  446
  447deny_all_users(Term) :-
  448    (   denied(X),
  449        X =@= Term
  450    ->  true
  451    ;   assert(denied(Term))
  452    ).
  453
  454
  455%!  login(+User:atom) is det.
  456%
  457%   Accept user as a user that has logged on into the current
  458%   session.
  459
  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]).
  470
  471
  472%!  logout(+User) is det.
  473%
  474%   Logout the specified user
  475
  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, [])