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): 2013-2015, VU University Amsterdam
    7
    8    This program is free software; you can redistribute it and/or
    9    modify it under the terms of the GNU General Public License
   10    as published by the Free Software Foundation; either version 2
   11    of the License, or (at your option) any later version.
   12
   13    This program is distributed in the hope that it will be useful,
   14    but WITHOUT ANY WARRANTY; without even the implied warranty of
   15    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   16    GNU General Public License for more details.
   17
   18    You should have received a copy of the GNU General Public
   19    License along with this library; if not, write to the Free Software
   20    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
   21
   22    As a special exception, if you link this library with other files,
   23    compiled with a Free Software compiler, to produce an executable, this
   24    library does not by itself cause the resulting executable to be covered
   25    by the GNU General Public License. This exception does not however
   26    invalidate any other reasons why the executable file might be covered by
   27    the GNU General Public License.
   28*/
   29
   30:- module(plweb_openid,
   31	  [ site_user/2,		% +Request, -User
   32	    site_user_logged_in/1,	% -User
   33	    site_user_property/2,	% +User, ?Property
   34	    grant/2,			% +User, +Token
   35	    revoke/2,			% +User, +Token
   36	    authenticate/3,		% +Request, +Token, -Fields
   37	    user_profile_link//1,	% +User
   38	    current_user//1,		% +PageStyle
   39	    current_user//0,
   40	    login_link//1,		% +Request
   41	    redirect_master/1		% +Request
   42	  ]).   43:- use_module(library(http/http_dispatch)).   44:- use_module(library(http/http_parameters)).   45:- use_module(library(http/http_session)).   46:- use_module(library(http/http_wrapper)).   47:- use_module(library(http/http_openid)).   48:- use_module(library(http/http_header)).   49:- use_module(library(http/http_path)).   50:- use_module(library(http/html_write)).   51:- use_module(library(http/js_write)).   52:- use_module(library(http/http_json)).   53:- use_module(library(http/html_head)).   54:- use_module(library(http/http_authenticate)).   55:- use_module(library(http/http_host)).   56:- use_module(library(http/recaptcha)).   57:- use_module(library(http/http_stream)).   58:- use_module(library(persistency)).   59:- use_module(library(settings)).   60:- use_module(library(debug)).   61:- use_module(library(uuid)).   62:- use_module(library(option)).   63:- use_module(library(error)).   64:- use_module(library(lists)).   65:- use_module(library(pairs)).   66:- use_module(library(google_client)).   67
   68:- use_module(parms).   69:- use_module(review).   70:- use_module(pack).   71:- use_module(wiki).   72:- use_module(markitup).   73:- use_module(tagit).   74:- use_module(post).   75
   76/** <module> Handle users of the SWI-Prolog website
   77
   78This module provide the OpenID interface  for the SWI-Prolog website. If
   79you want to run this for local installations, make sure that your server
   80is accessible through the public network   and first direct your browser
   81to the public network. Logging in using   Google  should work than. Some
   82other providers have more strict requirements.
   83
   84You can fake OpenID login using the debug interface:
   85
   86    ==
   87    ?- debug(openid_fake('WouterBeek')).
   88    ==
   89*/
   90
   91:- multifile
   92	http_openid:openid_hook/1.   93
   94:- persistent
   95	openid_user_server(user:atom,
   96			   server:atom),
   97	site_user(uuid:atom,
   98		  openid:atom,
   99		  name:atom,
  100		  email:atom,
  101		  home_url:atom),
  102	user_description(uuid:atom,
  103			 description:atom),
  104	stay_signed_in(openid:atom,
  105		       cookie:atom,
  106		       peer:atom,
  107		       time:integer,
  108		       expires:integer),
  109	granted(uuid:atom,
  110		token:atom).  111
  112:- initialization
  113	absolute_file_name(data('openid.db'), File,
  114			   [ access(write) ]),
  115	db_attach(File,
  116		  [ sync(close)
  117		  ]).  118
  119:- http_handler(root(user/create_profile),  create_profile, []).  120:- http_handler(root(user/submit_profile),  submit_profile, []).  121:- http_handler(root(user/logout),	    logout,         []).  122:- http_handler(root(user/view_profile),    view_profile,   []).  123:- http_handler(root(user/verify),          verify_user,    []).  124:- http_handler(root(user/list),            list_users,     []).  125:- http_handler(root(user/grant),           grant_user,     []).  126
  127
  128		 /*******************************
  129		 *	    USER ADMIN		*
  130		 *******************************/
  131
  132site_user_property(UUID, uuid(UUID)) :-
  133	(   site_user(UUID, _, _, _, _)
  134	->  true
  135	).
  136site_user_property(UUID, openid(OpenId)) :-
  137	site_user(UUID, OpenId, _, _, _).
  138site_user_property(UUID, name(Name)) :-
  139	site_user(UUID, _, Name, _, _).
  140site_user_property(UUID, email(Email)) :-
  141	site_user(UUID, _, _, Email, _).
  142site_user_property(UUID, home_url(Home)) :-
  143	site_user(UUID, _, _, _, Home).
  144site_user_property(UUID, granted(Token)) :-
  145	granted(UUID, Token).
  146site_user_property(UUID, granted_list(Tokens)) :-
  147	(   site_user(UUID, _, _, _, _)
  148	->  findall(Token, granted(UUID, Token), Tokens)
  149	).
  150
  151set_user_property(UUID, Prop) :-
  152	site_user_property(UUID, Prop), !.
  153set_user_property(UUID, openid(OpenId)) :-
  154	retract_site_user(UUID, _OldID, Name, Email, Home),
  155	assert_site_user(UUID, OpenId, Name, Email, Home).
  156
  157
  158		 /*******************************
  159		 *	      RIGHTS		*
  160		 *******************************/
  161
  162%%	grant(+User, +Token) is det.
  163%%	revoke(+User, +Token) is det.
  164%
  165%	Grant/revoke User (a UUID) the right to access Token.
  166
  167grant(User, Token) :-
  168	ground_user(User),
  169	must_be(atom, Token),
  170	granted(User, Token), !.
  171grant(User, Token) :-
  172	assert_granted(User, Token).
  173
  174revoke(User, Token) :-
  175	ground_user(User),
  176	must_be(atom, Token),
  177	\+ granted(User, Token), !.
  178revoke(User, Token) :-
  179	retract_granted(User, Token).
  180
  181ground_user(User) :-
  182	must_be(atom, User),
  183	site_user(User, _, _, _, _), !.
  184ground_user(User) :-
  185	existence_error(user, User).
  186
  187
  188%%	grant_user(+Request)
  189%
  190%	HTTP handler to grant or revoke rights for a user.
  191
  192grant_user(Request) :-
  193	catch(( http_read_json_dict(Request, Data),
  194		debug(grant, '~q', [Data]),
  195		admin_granted(Request),
  196		atom_string(UUID, Data.uuid),
  197		atom_string(Token, Data.token),
  198		(   Data.value == true
  199		->  grant(UUID, Token)
  200		;   revoke(UUID, Token)
  201		)
  202	      ), E,
  203	      throw(http_reply(bad_request(E)))),
  204	throw(http_reply(no_content)).
  205
  206admin_granted(_Request) :-
  207	site_user_logged_in(User),
  208	site_user_property(User, granted(admin)), !.
  209admin_granted(Request) :-
  210	memberchk(path(Path), Request),
  211	throw(http_reply(forbidden(Path))).
  212
  213%%	authenticate(+Request, +Token, -Fields)
  214%
  215%	Get authentication for editing wiki pages.  This now first tries
  216%	the OpenID login.
  217
  218authenticate(Request, Token, [UUID,Name]) :-
  219	site_user_logged_in(UUID),
  220	(   site_user_property(UUID, granted(Token))
  221	->  site_user_property(UUID, name(Name))
  222	;   option(path(Path), Request),
  223	    permission_error(access, http_location, Path)
  224	).
  225authenticate(Request, Token, Fields) :-
  226	redirect_master(Request),
  227	(   http_authenticate(basic(private(passwd)), Request, Fields)
  228	->  true
  229	;   format(atom(Msg), 'SWI-Prolog ~w authoring', [Token]),
  230		   throw(http_reply(authorise(basic, Msg)))
  231	).
  232
  233
  234		 /*******************************
  235		 *	 USER INTERACTION	*
  236		 *******************************/
  237
  238:- multifile recaptcha:key/2.  239
  240:- setting(recaptcha:public_key, atom, '',
  241	   'reCAPTCHA public key').  242:- setting(recaptcha:private_key, atom, '',
  243	   'reCAPTCHA private key').  244
  245recaptcha:key(public,  Key) :- setting(recaptcha:public_key,  Key).
  246recaptcha:key(private, Key) :- setting(recaptcha:private_key, Key).
  247
  248%%	site_user(+Request, -User)
  249%
  250%	Demand the user to be logged on and, if this is the first logon,
  251%	verify the user and create a profile.
  252
  253site_user(Request, User) :-
  254	openid_user(Request, OpenID, []),
  255	ensure_profile(OpenID, User).
  256
  257ensure_profile(OpenID, User) :-
  258	(   site_user_property(User, openid(OpenID))
  259	->  true
  260	;   http_current_request(Request),
  261	    option(request_uri(RequestURI), Request),
  262	    http_link_to_id(create_profile, [return(RequestURI)], HREF),
  263	    http_redirect(moved_temporary, HREF, Request)
  264	).
  265
  266%%	site_user_logged_in(-User) is semidet.
  267%
  268%	True when User is logged on.  Does not try to logon the user.
  269
  270site_user_logged_in(User) :-
  271	openid_logged_in(OpenID),
  272	site_user_property(User, openid(OpenID)).
  273
  274
  275%%	create_profile(+Request).
  276%
  277%	Create a new user profile, and on success return to the original
  278%	location.
  279
  280create_profile(Request) :-
  281	openid_user(Request, OpenID, []),
  282	http_parameters(Request,
  283			[ return(Return, [])
  284			]),
  285	reply_html_page(
  286	    user(create_profile),
  287	    title('Create user profile for SWI-Prolog'),
  288	    \create_profile(OpenID, Return)).
  289
  290
  291create_profile(OpenID, Return) -->
  292	{ (   site_user_property(User, openid(OpenID))
  293	  ->  Op = 'Update profile'
  294	  ;   uuid(User),		% new user
  295	      Op = 'Create profile'
  296	  )
  297	},
  298	html(h1(class(wiki), Op)),
  299	{ http_link_to_id(submit_profile, [], Action),
  300	  user_init_property(User, name(Name), ''),
  301	  user_init_property(User, email(Email), ''),
  302	  user_init_property(User, home_url(HomeURL), '')
  303	},
  304	html(form([ class(create_profile), method('POST'), action(Action) ],
  305		  [ input([type(hidden), name(return), value(Return)]),
  306		    input([type(hidden), name(uuid), value(User)]),
  307		    table([ tr([th('OpenID'),   td(input([ name(openid),
  308							   value(OpenID),
  309							   disabled(disabled)
  310							 ]))]),
  311			    tr([th('Name'),     td(input([ name(name),
  312							   value(Name),
  313							   placeholder('Displayed name')
  314							 ]))]),
  315			    tr([th('Email'),    td(input([ name(email),
  316							   value(Email),
  317							   placeholder('Your E-mail address')
  318							 ]))]),
  319			    tr([th('Home URL'), td(input([ name(home_url),
  320							   value(HomeURL),
  321							   placeholder('http://')
  322							 ]))]),
  323			    \description(User),
  324			    tr(td(colspan(2), \recaptcha([]))),
  325			    tr(td([colspan(2), align(right)],
  326				  input([type(submit), value(Op)])))
  327			  ])
  328		  ])),
  329	expain_create_profile.
  330
  331user_init_property(User, P, Default) :-
  332	(   site_user_property(User, P)
  333	->  true
  334	;   http_session_data(ax(AX)),
  335	    ax(P, AX)
  336	->  true
  337	;   arg(1, P, Default)
  338	).
  339
  340ax(email(AX.get(email)), AX).
  341ax(name(AX.get(name)), AX) :- !.
  342ax(name(Name), AX) :-
  343	atomic_list_concat([AX.get(firstname), AX.get(lastname)], ' ', Name), !.
  344ax(name(AX.get(nickname)), AX).
  345
  346expain_create_profile -->
  347	html({|html||
  348	       <div class="smallprint">
  349	       On this page, we ask you to proof you are human and
  350	       create a minimal profile. Your name is displayed along with comments
  351	       that you create.  Your E-mail and home URL are used to detect authorship of
  352	       packs. Your E-mail and home URL will not be displayed,
  353	       nor be used for spamming and not be handed to third parties.
  354	       The editor can be used to add a short description about yourself.
  355	       This description is shown on your profile page that collects
  356	       your packages and ratings and reviews you performed.
  357	       </div>
  358	       |}).
  359
  360%%	description(+UUID)//
  361%
  362%	Provide field for entering a description about the user.
  363
  364description(UUID) -->
  365	{ (   user_description(UUID, Description)
  366	  ->  Extra = [value(Description)]
  367	  ;   Extra = []
  368	  )
  369	},
  370	html(tr(td(colspan(2),
  371		   \markitup([ id(description),
  372			       markup(pldoc),
  373			       cold(60),
  374			       rows(10)
  375			     | Extra
  376			     ])))).
  377
  378%%	submit_profile(+Request)
  379%
  380%	Handle submission of the user profile
  381
  382submit_profile(Request) :-
  383	openid_user(Request, OpenID, []),
  384	recaptcha_parameters(ReCAPTCHA),
  385	http_parameters(Request,
  386			[ uuid(User,         []),
  387			  name(Name0,        [optional(true), default(anonymous)]),
  388			  email(Email0,      [optional(true), default('')]),
  389			  home_url(Home0,    [optional(true), default('')]),
  390			  description(Descr, [optional(true), default('')]),
  391			  return(Return, [])
  392			| ReCAPTCHA
  393			]),
  394	(   catch(recaptcha_verify(Request, ReCAPTCHA), E, true)
  395	->  (   var(E)
  396	    ->  retractall_site_user(User, OpenID, _, _, _),
  397		normalize_space(atom(Name),  Name0),
  398		normalize_space(atom(Email), Email0),
  399		normalize_space(atom(Home),  Home0),
  400		assert_site_user(User, OpenID, Name, Email, Home),
  401		update_description(User, Descr),
  402		http_redirect(moved_temporary, Return, Request)
  403	    ;	E = error(domain_error(recaptcha_response, _), _)
  404	    ->	retry_captcha('CAPTCHA required', '')
  405	    ;	message_to_string(E, Msg)
  406	    ->	retry_captcha('CAPTCHA processing error', Msg)
  407	    )
  408	;   retry_captcha('CAPTCHA verification failed', '')
  409	).
  410
  411retry_captcha(Why, Warning) :-
  412	reply_html_page(
  413	    plain,
  414	    title('CAPTCHA failed'),
  415	    [ h1(class(wiki), Why),
  416	      p(class(error), Warning),
  417	      p([ 'Please use the back button of your browser and ',
  418		  'try again'
  419		])
  420	    ]).
  421
  422
  423update_description(UUID, '') :- !,
  424	retractall_user_description(UUID, _).
  425update_description(UUID, Description) :- !,
  426	retractall_user_description(UUID, _),
  427	assert_user_description(UUID, Description).
  428
  429%%	view_profile(+Request) is det.
  430%
  431%	HTTP handler showing the public  profile   for  a  user. Viewing
  432%	options:
  433%
  434%	  | Requested user is logged on | [view(private), edit_link(true)] |
  435%	  | Logged on is =admin=        | [view(admin)] |
  436%	  | Not logged on		| [view(public) |
  437
  438view_profile(Request) :-
  439	http_parameters(Request,
  440			[ user(UUID, [ optional(true) ])
  441			]),
  442	(   site_user_logged_in(User)
  443	->  (   User = UUID
  444	    ->  (   site_user_property(User, granted(admin))
  445		->  Options = [view(admin), edit_link(true)]
  446		;   Options = [view(private), edit_link(true)]
  447		)
  448	    ;	site_user_property(User, granted(admin))
  449	    ->	Options = [view(admin)]
  450	    ;	Options = [view(public)]
  451	    )
  452	;   (   var(UUID)
  453	    ->	existence_error(http_parameter, user)
  454	    ;	Options = [view(public)]
  455	    )
  456	),
  457	site_user_property(UUID, name(Name)),
  458	reply_html_page(
  459	    user(view_profile(UUID)),
  460	    title('User ~w'-[Name]),
  461	    [ \edit_link(UUID, Options),
  462	      \view_profile(UUID, Options)
  463	    ]).
  464
  465view_profile(UUID, Options) -->
  466	private_profile(UUID, Options),
  467	user_description(UUID, Options),
  468	user_tags(UUID, []),
  469	user_posts(UUID, annotation),
  470	user_posts(UUID, news),
  471	user_packs(UUID),
  472	profile_reviews(UUID).
  473
  474%%	private_profile(+UUID, +Options)// is det.
  475%
  476%	If the user is viewing his/her own profile or the logged on user
  477%	has =admin= rights, show a  table   holding  the private profile
  478%	information.
  479
  480private_profile(UUID, Options) -->
  481	{ option(view(private), Options)
  482	; option(view(admin), Options)
  483	}, !,
  484	html([ div(class('private-profile'),
  485		   [ h2(class(wiki),
  486			[ 'Private profile data',
  487			  \link_list_users
  488			]),
  489		     table([ \profile_data(UUID, 'Name',      name),
  490			     \profile_data(UUID, 'OpenID',    openid),
  491			     \profile_data(UUID, 'E-Mail',    email),
  492			     \profile_data(UUID, 'Home page', home_url)
  493			   | \admin_profile(UUID, Options)
  494			   ])
  495		   ]),
  496	       div(class(smallprint),
  497		   'The above private information is shown only to the owner.')
  498	     ]).
  499private_profile(_, _) --> [].
  500
  501admin_profile(UUID, Options) -->
  502	{ option(view(admin), Options) }, !,
  503	html([ \profile_data(UUID, 'UUID',    uuid),
  504	       \profile_data(UUID, 'Granted', granted_list)
  505	     ]).
  506admin_profile(_, _) --> [].
  507
  508link_list_users -->
  509	{ http_link_to_id(list_users, [], HREF)
  510	},
  511	html(a([ class('list-other-users'),
  512		 style('float:right;'),
  513		 href(HREF)
  514	       ], 'other users')).
  515
  516create_profile_link(HREF) :-
  517	http_current_request(Request),
  518	option(request_uri(Here), Request),
  519	http_link_to_id(create_profile, [return(Here)], HREF).
  520
  521profile_data(UUID, Label, Field) -->
  522	{ Term =.. [Field,Value],
  523	  site_user_property(UUID, Term),
  524	  (   value_dom(Field, UUID, Value, DOM)
  525	  ->  true
  526	  )
  527	},
  528	html(tr([ th([Label,:]),
  529		  td(DOM)
  530		])).
  531
  532value_dom(name,		_,    Name,    Name).
  533value_dom(uuid,		_,    UUID,    UUID).
  534value_dom(email,	_,    Email,   a(href('mailto:'+Email), Email)).
  535value_dom(granted_list,	UUID, Tokens, \token_list(UUID, Tokens, [edit(true)])).
  536value_dom(_,		_,    URL,     a(href(URL), URL)).
  537
  538%%	user_description(UUID, +Options)// is det.
  539%
  540%	Show user description
  541
  542user_description(UUID, _Options) -->
  543	{ user_description(UUID, Description),
  544	  Description \== '', !,
  545	  atom_codes(Description, Codes),
  546	  wiki_file_codes_to_dom(Codes, /, DOM0),
  547	  clean_dom(DOM0, DOM)
  548	},
  549	html(DOM).
  550user_description(_UUID, Options) -->
  551	{ option(edit_link(true), Options),
  552	  create_profile_link(Edit)
  553	},
  554	html([ i('No description.'),
  555	       ' Click ', a(href(Edit), here), ' to create one'
  556	     ]).
  557user_description(_, _) --> [].
  558
  559clean_dom([p(X)], X) :- !.
  560clean_dom(X, X).
  561
  562edit_link(_UUID, Options) -->
  563	{ option(edit_link(true), Options), !,
  564	  create_profile_link(Edit)
  565	},
  566	html(div(class('edit-profile'),
  567		 [ a(href(Edit), 'Edit'), ' profile'])).
  568edit_link(_, _) --> [].
  569
  570
  571%%	user_packs(UUID)// is det.
  572%
  573%	Show a filtered version of the pack table, holding the packs
  574%	created by this user.
  575
  576user_packs(UUID) -->
  577	{ setof(Pack, current_pack([author(UUID)], Pack), Packs), !,
  578	  sort_packs(rating, Packs, Sorted),
  579	  site_user_property(UUID, name(Name))
  580	},
  581	html([ h2(class(wiki), 'Packages by ~w'-[Name])
  582	     ]),
  583	pack_table(Sorted, []),
  584	html([ div(class(smallprint),
  585		   [ 'This list contains packages whose author name, e-mail ',
  586		     'or homepage url matches the profile information.'
  587		   ])
  588	     ]).
  589user_packs(_) -->
  590	[].
  591
  592
  593%%	list_users(+Request)
  594%
  595%	HTTP handler to list known users.
  596
  597list_users(_Request) :-
  598	site_user_logged_in(User), !,
  599	(   site_user_property(User, granted(admin))
  600	->  ShowAdmin = true
  601	;   ShowAdmin = false
  602	),
  603	findall(Kudos-Details,
  604		site_kudos(_UUID, Details, Kudos),
  605		Pairs),
  606	keysort(Pairs, Sorted),
  607	pairs_values(Sorted, Users),
  608	reverse(Users, BestFirst),
  609	reply_html_page(
  610	    user(list),
  611	    title('SWI-Prolog site users'),
  612	    [ \explain_user_listing,
  613	      \html_requires(css('stats.css')),
  614	      table(class(block),
  615		    [ \user_table_header(ShowAdmin)
  616		    | \user_rows(BestFirst, ShowAdmin)
  617		    ])
  618	    ]).
  619list_users(_Request) :-
  620	reply_html_page(
  621	    user(list),
  622	    title('Permission denied'),
  623	    [ \explain_user_listing_not_logged_on
  624	    ]).
  625
  626site_kudos(UUID, Details, Kudos) :-
  627	Details = _{ user:UUID,
  628		     news:NewsArticles,
  629		     annotations:Annotations,
  630		     reviews:Reviews,
  631		     tags:Tags,
  632		     votes:Up-Down
  633		   },
  634	site_user(UUID, _, _, _, _),
  635	user_post_count(UUID, news, NewsArticles),
  636	user_post_count(UUID, annotation, Annotations),
  637	user_review_count(UUID, Reviews),
  638	user_tag_count(UUID, Tags),
  639	user_vote_count(UUID, Up, Down),
  640	Kudos is ( NewsArticles*20 +
  641		   Reviews*10 +
  642		   Annotations*10 +
  643		   Tags*2 +
  644		   Up+Down
  645		 ).
  646
  647explain_user_listing -->
  648	html({|html||
  649	      <p>Below is a listing of all registered users with some
  650	      basic properties.  This is list only visible to other
  651	      registered users.
  652	     |}).
  653
  654explain_user_listing_not_logged_on -->
  655	html({|html||
  656	      <h1 class="wiki">Permission denied</h1>
  657
  658	      <p class="warning">A listing of all registered users is only
  659	      available to users who are logged in.
  660	     |}).
  661
  662user_rows([], _) --> [].
  663user_rows([H|T], ShowAdmin) --> user_row(H, ShowAdmin), user_rows(T, ShowAdmin).
  664
  665user_table_header(ShowAdmin) -->
  666	html(tr([th('User'),
  667		 th('#Comments'),
  668		 th('#Reviews'),
  669		 th('#Votes'),
  670		 th('#Tags'),
  671		 \admin_header(ShowAdmin)
  672		])).
  673
  674admin_header(true) --> !,
  675	html([ th('Granted'),
  676	       th('E-mail')
  677	     ]).
  678admin_header(_) --> [].
  679
  680user_row(Details, ShowAdmin) -->
  681	{ Up-Down = Details.votes },
  682	html(tr([td(\user_profile_link(Details.user)),
  683		 td(Details.annotations),
  684		 td(Details.reviews),
  685		 td('+~d-~d'-[Up,Down]),
  686		 td(Details.tags),
  687		 \admin_columns(Details.user, ShowAdmin)
  688		])).
  689
  690admin_columns(UUID, true) --> !,
  691	{ site_user_property(UUID, granted_list(Tokens)),
  692	  site_user_property(UUID, email(Email))
  693	},
  694	html([ td(\token_list(UUID, Tokens, [])),
  695	       td(\email(Email))
  696	     ]).
  697admin_columns(_, _) --> [].
  698
  699token_list(UUID, Tokens, Options) -->
  700	{ option(edit(true), Options), !,
  701	  http_link_to_id(grant_user, [], Action)
  702	},
  703	html([ \token(wiki,  UUID, Tokens),
  704	       \token(news,  UUID, Tokens),
  705	       \token(admin, UUID, Tokens)
  706	     ]),
  707	html_post(script, \granted_script(Action)).
  708token_list(_, Tokens, _Options) -->
  709	token_list(Tokens).
  710
  711token_list([]) --> [].
  712token_list([H|T]) -->
  713	html(H),
  714	(   {T==[]}
  715	->  []
  716	;   html([', ']),
  717	    token_list(T)
  718	).
  719
  720token(Token, UUID, Active) -->
  721	{   memberchk(Token, Active)
  722	->  Extra = [checked(checked)]
  723	;   Extra = []
  724	},
  725	html([ input([ type(checkbox),
  726		       class(grant),
  727		       name(Token),
  728		       value(UUID)
  729		     | Extra
  730		     ]),
  731	       Token
  732	     ]).
  733
  734granted_script(Action) -->
  735	js_script({|javascript(Action)||
  736$(document).ready(function() {
  737  $("input.grant").click(function(e)
  738  { e.preventDefault();
  739    var checkbox = $(this);
  740    var checked  = checkbox.prop("checked");
  741    var token    = checkbox.prop("name");
  742    var UUID     = checkbox.prop("value");
  743    $.ajax(Action,
  744	   { "contentType": "application/json; charset=utf-8",
  745	     "dataType": "json",
  746	     "data": JSON.stringify({ uuid:  UUID,
  747				      value: checked,
  748				      token: token
  749				    }),
  750	     "success": function() {
  751		checkbox.prop("checked", checked);
  752	     },
  753	     "type": "POST"
  754	   });
  755  });
  756});
  757		  |}).
  758
  759
  760email(Mail) -->
  761	html(a(href('mailto:'+Mail), Mail)).
  762
  763
  764		 /*******************************
  765		 *	     COMPONENTS		*
  766		 *******************************/
  767
  768%%	user_profile_link(+UUID)//
  769%
  770%	Create a link to the profile of a user.
  771
  772user_profile_link(UUID) -->
  773	{ site_user_property(UUID, name(Name)),
  774	  http_link_to_id(view_profile, [user(UUID)], HREF)
  775	}, !,
  776	html(a([class(user), href(HREF)], Name)).
  777
  778
  779		 /*******************************
  780		 *     OPENID CUSTOMIZATION	*
  781		 *******************************/
  782
  783stay_login_cookie(swipl_login).
  784
  785http_openid:openid_hook(trusted(OpenId, Server)) :-
  786	openid_user_server(OpenId, Server), !.
  787http_openid:openid_hook(trusted(OpenId, Server)) :-
  788	assert_openid_user_server(OpenId, Server), !.
  789http_openid:openid_hook(stay_signed_in(OpenId)) :-
  790	assertion(in_header_state),
  791	http_session_cookie(Cookie),
  792	get_time(NowF),
  793	Now is round(NowF),
  794	http_current_request(Request),
  795	http_peer(Request, Peer),
  796	Expires is Now+31*24*60*60,	% 31 days from now
  797	assert_stay_signed_in(OpenId, Cookie, Peer, Now, Expires),
  798	http_session_option(path(Path)),
  799	debug(openid(stay_signed_in),
  800	      'Created stay-signed-in for ~q', [OpenId]),
  801	http_timestamp(Expires, RFC1123),
  802	stay_login_cookie(CookieName),
  803	format('Set-Cookie: ~w=~w; Expires=~w; path=~w\r\n',
  804	       [CookieName, Cookie, RFC1123, Path]).
  805http_openid:openid_hook(logout(OpenId)) :-
  806	nonvar(OpenId),
  807	assertion(in_header_state),
  808	retractall_stay_signed_in(OpenId, _, _, _, _),
  809	http_session_option(path(Path)),
  810	stay_login_cookie(CookieName),
  811	format('Set-Cookie: ~w=; \c
  812	        expires=Tue, 01-Jan-1970 00:00:00 GMT; \c
  813		path=~w\r\n',
  814	       [CookieName, Path]),
  815	fail.
  816http_openid:openid_hook(logged_in(OpenId)) :-
  817	(   debugging(openid_fake(User)),
  818	    atom(User)
  819	->  debug(openid_fake(User), 'Fake login for ~q.', [User]),
  820	    OpenId = User
  821	;   http_in_session(_),
  822	    http_session_data(openid(OpenId))
  823	->  true
  824	;   http_current_request(Request),
  825	    memberchk(cookie(Cookies), Request),
  826	    memberchk(swipl_login=Cookie, Cookies),
  827	    stay_signed_in(OpenId, Cookie, _Peer, _Time, _Expires)
  828	->  http_open_session(_, []),
  829	    http_session_assert(openid(OpenId)),
  830	    debug(openid(stay_signed_in),
  831		  'Granted stay-signed-in for ~q', [OpenId])
  832	).
  833% see https://developers.google.com/accounts/docs/OpenID#shutdown-timetable
  834http_openid:openid_hook(x_parameter('https://www.google.com/accounts/o8/ud',
  835				    openid_shutdown_ack,
  836				    '2015-04-20')).
  837
  838
  839%%	yadis:xrds_specified_location(+Server, -XRDSLocation)
  840%
  841%	Hacks to deal with broken Yadis support.
  842%
  843%	  - Google does not support Yadis discovery, but does have an
  844%	    XRSD document, so we fake its location.
  845%	  - stackexchange.com serves an _OP Identifier Element_ instead
  846%	    of an _Claimed Identifier Element_ when doing Yadis
  847%	    discovery on the real OpenID.
  848
  849:- multifile
  850	yadis:xrds_specified_location/2.  851
  852yadis:xrds_specified_location('http://google.com/',
  853			      'https://www.google.com/accounts/o8/id').
  854yadis:xrds_specified_location(StackOverFlow, -) :-
  855	sub_atom(StackOverFlow, 0, _, A, 'https://openid.stackexchange.com/'),
  856	A > 0.
  857
  858
  859in_header_state :-
  860	current_output(CGI),
  861	cgi_property(CGI, state(header)), !.
  862
  863:- http_handler(openid(login),  plweb_login_page, [id(swipl_login)]).  864
  865%%	plweb_login_page(+Request)
  866%
  867%	HTTP handler that  overrules  the   location  openid(login)  for
  868%	customizating the -very basic- login page.
  869
  870plweb_login_page(Request) :-
  871	redirect_master(Request),
  872	memberchk(host(localhost), Request),
  873	\+ ( debugging(openid_fake(User)),
  874	     atom(User)
  875	   ),
  876	\+ http_public_host(Request, localhost, _, []),
  877	openid_current_url(Request, URL), !,
  878	throw(http_reply(see_other(URL))).
  879plweb_login_page(Request) :-
  880	http_open_session(_, []),
  881	http_parameters(Request,
  882			[ 'openid.return_to'(ReturnTo, [])
  883			]),
  884	http_link_to_id(verify_user, [], Action),
  885	quick_buttons(Buttons),
  886	reply_html_page(user(login),
  887			[ title('SWI-Prolog login')
  888			],
  889			[ \openid_login_form(
  890			       ReturnTo,
  891			       [ show_stay(true),
  892				 action(Action),
  893				 buttons(Buttons)
  894			       ]),
  895			  \explain
  896			]).
  897
  898explain -->
  899	html([ div(class(smallprint),
  900		   [ p([ 'Actions such as rating, commenting and tagging ',
  901			 'requires you to be signed in. ',
  902			 'We use ', a(href('http://openid.net/'), 'OpenID'), '. ',
  903			 'Currently, we accept any OpenID provider. ',
  904			 'Tested with ', \openid_ok
  905		       ]),
  906		     p([ 'After logging in for the first time, we will ask for ',
  907			 'some additional information.  All information is ',
  908			 'optional.'
  909		       ])
  910		   ])
  911	     ]).
  912
  913
  914%%	quick_buttons(-Buttons) is det.
  915%
  916%	Create a list of img(Attributes) terms for quick login.
  917
  918quick_buttons(Buttons) :-
  919	findall(Img, quick_button(Img), Buttons).
  920
  921quick_button(img([ src(Icon),
  922		   href(Provider),
  923		   alt(Name),
  924		   title('Sign in with '+Name)
  925		 ])) :-
  926	openid_provider(2, Provider, Name, ImgName),
  927	http_absolute_location(icons(ImgName), Icon, []).
  928
  929openid_provider(2, LoginWithGoogle, 'Google', 'social_google_box.png') :-
  930	http_link_to_id(login_with_google, [], LoginWithGoogle).
  931openid_provider(2, 'http://me.yahoo.com',  'Yahoo', 'social_yahoo_box_lilac.png').
  932openid_provider(1, 'https://openid.stackexchange.com/%user%', 'StackExchange', -).
  933
  934openid_ok -->
  935	{ Term = openid_provider(_Version, _URL, _Name, _Icon),
  936	  findall(Term, Term, Terms)
  937	},
  938	openid_ok(Terms).
  939
  940openid_ok([]) --> [].
  941openid_ok([H|T]) -->
  942	openid_ok1(H),
  943	(   {T == []}
  944	->  []
  945	;   html(', '),
  946	    openid_ok(T)
  947	).
  948
  949openid_ok1(openid_provider(2, URL, Name, _Icon)) --> !,
  950	html(a(href(URL), Name)).
  951openid_ok1(openid_provider(1, URL, Name, _Icon)) --> !,
  952	html([ Name, ' using the url ',
  953	       span(class('openid-url-pattern'), URL)
  954	     ]).
  955
  956
  957%%	verify_user(+Request)
  958%
  959%	HTTP handler for SWI-Prolog  site   login.  Calls openid_verify,
  960%	asking for additional attribute exchange.
  961
  962verify_user(Request) :-
  963	openid_verify([ ax([ email(_, [required]),
  964			     nickname(_),
  965			     fullname(_),
  966			     firstname(_),
  967			     lastname(_)
  968			   ])
  969		      ], Request).
  970
  971
  972		 /*******************************
  973		 *	   GOOGLE LOGIN		*
  974		 *******************************/
  975
  976:- if(current_predicate(oauth_authenticate/3)).  977
  978:- http_handler(root(user/login_with_google), login_with_google, []).  979
  980:- setting(google:client_id, atom, '',
  981	   'Google project ClientID code').  982:- setting(google:client_secret, atom, '',
  983	   'Google project ClientSecret code').  984
  985%%	login_with_google(+Request)
  986%
  987%	HTTP handler to login with Google.
  988
  989login_with_google(Request) :-
  990	http_parameters(Request,
  991			[ 'openid.return_to'(ReturnTo, [default(/)]),
  992			  stay(Stay, [default(false)])
  993			]),
  994	oauth_authenticate(Request, 'google.com',
  995			   [client_data(_{return_to:ReturnTo, stay:Stay})]).
  996
  997:- multifile
  998	google_client:key/2,
  999	google_client:login_existing_user/1,
 1000	google_client:create_user/1. 1001
 1002google_client:key(client_id, ClientID) :-
 1003	setting(google:client_id, ClientID).
 1004google_client:key(client_secret, ClientSecret) :-
 1005	setting(google:client_secret, ClientSecret).
 1006
 1007%%	google_client:login_existing_user(+Claim) is semidet.
 1008%
 1009%	True if the user is know to us and thus we can perform the login
 1010%	without further interaction.
 1011
 1012google_client:login_existing_user(Claim) :-
 1013	google_fake_open_id(Claim, GoogleID),
 1014	site_user_property(_User, openid(GoogleID)), !,
 1015	google_login(Claim).
 1016google_client:login_existing_user(Claim) :-
 1017	downcase_atom(Claim.get(email), ClaimedEmail),
 1018	site_user_property(UUID, email(Email)),
 1019	downcase_atom(Email, ClaimedEmail), !,
 1020	debug(google, 'Found ~p with ~p', [UUID, Claim.email]),
 1021	google_fake_open_id(Claim, GoogleID),
 1022	set_user_property(UUID, openid(GoogleID)),
 1023	google_login(Claim).
 1024
 1025%%	google_client:create_user(+Profile) is det.
 1026%
 1027%	Create a new user for the given Google Profile.
 1028
 1029google_client:create_user(Profile) :-
 1030	http_session_assert(ax(Profile)),
 1031	google_login(Profile).
 1032
 1033google_login(Claim) :-
 1034	http_open_session(_, []),
 1035	google_fake_open_id(Claim, GoogleID),
 1036	http_session_retractall(openid(_)),
 1037	http_session_assert(openid(GoogleID)),
 1038	http_current_request(Request),
 1039	(   true(Claim.client_data.stay)
 1040	->  debug(google, 'Stay signed in: ~p', [GoogleID]),
 1041	    http_openid:openid_hook(stay_signed_in(GoogleID))
 1042	;   true
 1043	),
 1044	http_redirect(moved_temporary, Claim.client_data.return_to, Request).
 1045
 1046google_fake_open_id(Claim, GoogleID) :-
 1047	atomic_list_concat(['http://google.com/fake_open_id/', Claim.sub],
 1048			   GoogleID).
 1049
 1050true(true).
 1051true(yes).
 1052
 1053:- endif. 1054
 1055
 1056		 /*******************************
 1057		 *	      LOGOUT		*
 1058		 *******************************/
 1059
 1060%%	logout(+Request)
 1061%
 1062%	Logout  the  current  user.  If  openid.return_to  is  provided,
 1063%	provide a back-link
 1064
 1065logout(Request) :-
 1066	openid_logged_in(OpenId), !,
 1067	openid_logout(OpenId),
 1068	reply_html_page(
 1069	    user(logout),
 1070	    title('Logged out'),
 1071	    [ p('Thanks for using www.swi-prolog.org'),
 1072	      \logout_back_link(Request)
 1073	    ]).
 1074logout(Request) :-
 1075	reply_html_page(
 1076	    user(logout),
 1077	    title('Not logged in'),
 1078	    [ p(class(warning), 'You are not logged in'),
 1079	      \logout_back_link(Request)
 1080	    ]).
 1081
 1082
 1083logout_back_link(Request) -->
 1084	{ http_parameters(Request,
 1085			  [ 'openid.return_to'(Return, [optional(true)])
 1086			  ]),
 1087	  nonvar(Return)
 1088	}, !,
 1089	html(p(['Go ', a(href(Return), back), '.'])).
 1090logout_back_link(_) -->
 1091	[].
 1092
 1093
 1094%%	current_user//
 1095
 1096current_user -->
 1097	current_user(default).
 1098
 1099current_user(Style) -->
 1100	{ Style \== create_profile,
 1101	  openid_logged_in(OpenID), !,
 1102	  ensure_profile(OpenID, User),
 1103	  (   site_user_property(User, name(Name)),
 1104	      Name \== ''
 1105	  ->  Display = Name
 1106	  ;   Display = OpenID
 1107	  ),
 1108	  http_link_to_id(view_profile, [], Profile)
 1109	},
 1110	html(div(class('current-user'),
 1111		 [ a([href(Profile)], Display),
 1112		   ' (', \logout_link, ')'
 1113		 ])).
 1114current_user(Style) -->
 1115	{ Style \== create_profile,
 1116	  http_current_request(Request), !
 1117	},
 1118	html(div(class('current-user'),
 1119		 \login_link(Request))).
 1120current_user(_Style) -->
 1121	[].
 1122
 1123%%	login_link(+Request)//
 1124%
 1125%	Create a link to login, which returns to the current page.
 1126
 1127login_link(Request) -->
 1128	{ (   memberchk(request_uri(Here), Request)
 1129	  ->  Attrs = ['openid.return_to'(Here)]
 1130	  ;   Attrs = []
 1131	  ),
 1132	  http_link_to_id(swipl_login, Attrs, Login)
 1133	},
 1134	html(a([class(signin), href(Login)], login)).
 1135
 1136%%	logout_link//
 1137%
 1138%	Create a link to logout
 1139
 1140logout_link -->
 1141	{ http_link_to_id(logout, [], Logout) },
 1142	html(a([href(Logout)], 'logout')).
 1143
 1144
 1145%%	redirect_master(+Request)
 1146%
 1147%	Redirect a request to the master server,   so  we do not have to
 1148%	deal with multiple versions of the database files.
 1149
 1150redirect_master(Request) :-
 1151	option(host(Host), Request),
 1152	server(_, Host),
 1153	server(master, Master),
 1154	Host \== Master, !,
 1155	option(request_uri(URI), Request),
 1156	format(string(To), 'https://~w~w', [Master, URI]),
 1157	http_redirect(see_other, To, Request)