Chris@0: /*  $Id$
Chris@0: 
Chris@0:     Part of SWI-Prolog
Chris@0: 
Chris@0:     Author:        Jan Wielemaker
Chris@0:     E-mail:        wielemak@science.uva.nl
Chris@0:     WWW:           http://www.swi-prolog.org
Chris@0:     Copyright (C): 1985-2007, University of Amsterdam
Chris@0: 
Chris@0:     This program is free software; you can redistribute it and/or
Chris@0:     modify it under the terms of the GNU General Public License
Chris@0:     as published by the Free Software Foundation; either version 2
Chris@0:     of the License, or (at your option) any later version.
Chris@0: 
Chris@0:     This program is distributed in the hope that it will be useful,
Chris@0:     but WITHOUT ANY WARRANTY; without even the implied warranty of
Chris@0:     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
Chris@0:     GNU General Public License for more details.
Chris@0: 
Chris@0:     You should have received a copy of the GNU Lesser General Public
Chris@0:     License along with this library; if not, write to the Free Software
Chris@0:     Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
Chris@0: 
Chris@0:     As a special exception, if you link this library with other files,
Chris@0:     compiled with a Free Software compiler, to produce an executable, this
Chris@0:     library does not by itself cause the resulting executable to be covered
Chris@0:     by the GNU General Public License. This exception does not however
Chris@0:     invalidate any other reasons why the executable file might be covered by
Chris@0:     the GNU General Public License.
Chris@0: */
Chris@0: 
Chris@0: :- module(http_admin,
Chris@0: 	  [ reload_attr/2		% +Window, -Attribute
Chris@0: 	  ]).
Chris@0: :- use_module(user_db).
Chris@0: :- use_module(library('http/http_parameters')).
Chris@0: :- use_module(library('http/http_session')).
Chris@0: :- use_module(library('http/html_write')).
Chris@0: :- use_module(library('http/mimetype')).
Chris@0: :- use_module(library('http/http_dispatch')).
Chris@0: :- use_module(library(url)).
Chris@0: :- use_module(library(debug)).
Chris@0: :- use_module(library(lists)).
Chris@0: :- use_module(library(option)).
Chris@0: :- use_module(library(http_settings)).
Chris@0: 
Chris@0: 
Chris@0: :- http_handler('/admin/tasks',			tasks,			 []).
Chris@0: :- http_handler('/admin/listUsers',		list_users,		 []).
Chris@0: :- http_handler('/admin/form/createAdmin',	create_admin,		 []).
Chris@0: :- http_handler('/admin/form/addUser',		add_user_form,		 []).
Chris@0: :- http_handler('/admin/form/addOpenIDServer',	add_openid_server_form,	 []).
Chris@0: :- http_handler('/admin/addUser',		add_user,		 []).
Chris@0: :- http_handler('/admin/addOpenIDServer',	add_openid_server,	 []).
Chris@0: :- http_handler('/admin/form/editUser',		edit_user_form,		 []).
Chris@0: :- http_handler('/admin/editUser',		edit_user,		 []).
Chris@0: :- http_handler('/admin/delUser',		del_user,		 []).
Chris@0: :- http_handler('/admin/form/editOpenIDServer',	edit_openid_server_form, []).
Chris@0: :- http_handler('/admin/editOpenIDServer',	edit_openid_server,      []).
Chris@0: :- http_handler('/admin/delOpenIDServer',	del_openid_server,       []).
Chris@0: :- http_handler('/admin/form/changePassword',	change_password_form,	 []).
Chris@0: :- http_handler('/admin/changePassword',	change_password,	 []).
Chris@0: :- http_handler('/user/form/login',		login_form,		 []).
Chris@0: :- http_handler('/user/login',			user_login,		 []).
Chris@0: :- http_handler('/user/logout',			user_logout,		 []).
Chris@0: :- http_handler('/admin/settings',		settings,		 []).
Chris@0: :- http_handler('/admin/save_settings',		save_settings,		 []).
Chris@0: :- http_handler('/css/settings.css', http_reply_file(library('settings.css'), []), []).
Chris@0: 
Chris@0: %%	tasks(+Request)
Chris@0: %
Chris@0: %	Present menu with administrative tasks.
Chris@0: 
Chris@0: tasks(_Request) :-
Chris@0: 	reply_page('Administrative tasks',
Chris@0: 		   [ \action('listUsers', 'List users')
Chris@0: 		   ]).
Chris@0: 
Chris@0: 
Chris@0: action(URL, Label) -->
Chris@0: 	html([a([target=main, href=URL], Label), br([])]).
Chris@0: 
Chris@0: %%	list_users(+Request)
Chris@0: %
Chris@0: %	HTTP Handler listing registered users.
Chris@0: 
Chris@0: list_users(_Request) :-
Chris@0: 	authorized(admin(list_users)),
Chris@0: 	reply_page('Users',
Chris@0: 		   [ h1('Users'),
Chris@0: 		     \user_table,
Chris@0: 		     p([ \action('form/addUser', 'Add user')
Chris@0: 		       ]),
Chris@0: 		     h1('OpenID servers'),
Chris@0: 		     \openid_server_table,
Chris@0: 		     p([ \action('form/addOpenIDServer', 'Add OpenID server')
Chris@0: 		       ])
Chris@0: 		   ]).
Chris@0: 
Chris@0: %%	user_table//
Chris@0: %
Chris@0: %	HTML DCG generating a table of registered users.
Chris@0: 
Chris@0: user_table -->
Chris@0: 	{ setof(U, current_user(U), Users)
Chris@0: 	},
Chris@0: 	html([ table([ border(1)
Chris@0: 		     ],
Chris@0: 		     [ tr([ th('UserID'),
Chris@0: 			    th('RealName'),
Chris@0: 			    th('On since'),
Chris@0: 			    th('Idle')
Chris@0: 			  ])
Chris@0: 		     | \list_users(Users)
Chris@0: 		     ])
Chris@0: 	     ]).
Chris@0: 
Chris@0: list_users([]) -->
Chris@0: 	[].
Chris@0: list_users([User|T]) -->
Chris@0: 	{ user_property(User, realname(Name)),
Chris@0: 	  www_form_encode(User, Encoded),
Chris@0: 	  format(string(Edit), 'form/editUser?user=~w', [Encoded]),
Chris@0: 	  findall(Idle-Login,
Chris@0: 		  user_property(User, connection(Login, Idle)),
Chris@0: 		  Pairs0),
Chris@0: 	  keysort(Pairs0, Pairs),
Chris@0: 	  (   Pairs == []
Chris@0: 	  ->  OnLine = (-)
Chris@0: 	  ;   length(Pairs, N),
Chris@0: 	      Pairs = [Idle-Login|_],
Chris@0: 	      OnLine = online(Login, Idle, N)
Chris@0: 	  )
Chris@0: 	},
Chris@0: 	html(tr([ td(User),
Chris@0: 		  td(Name),
Chris@0: 		  td(\on_since(OnLine)),
Chris@0: 		  td(\idle(OnLine)),
Chris@0: 		  td(a(href(Edit), 'Edit'))
Chris@0: 		])),
Chris@0: 	list_users(T).
Chris@0: 
Chris@0: on_since(online(Login, _Idle, _Connections)) --> !,
Chris@0: 	{ format_time(string(Date), '%+', Login)
Chris@0: 	},
Chris@0: 	html(Date).
Chris@0: on_since(_) -->
Chris@0: 	html(-).
Chris@0: 
Chris@0: idle(online(_Login, Idle, _Connections)) -->
Chris@0: 	{ mmss_duration(Idle, String)
Chris@0: 	},
Chris@0: 	html(String).
Chris@0: idle(_) -->
Chris@0: 	html(-).
Chris@0: 	
Chris@0: 
Chris@0: mmss_duration(Time, String) :-		% Time in seconds
Chris@0: 	Secs is round(Time),
Chris@0: 	Hour is Secs // 3600, 
Chris@0: 	Min  is (Secs // 60) mod 60,
Chris@0: 	Sec  is Secs mod 60,
Chris@0: 	format(string(String), '~`0t~d~2|:~`0t~d~5|:~`0t~d~8|', [Hour, Min, Sec]).
Chris@0: 
Chris@0: 
Chris@0: 
Chris@0: 		 /*******************************
Chris@0: 		 *	      ADD USERS		*
Chris@0: 		 *******************************/
Chris@0: 
Chris@0: %%	create_admin(+Request)
Chris@0: %	
Chris@0: %	Create the administrator login.
Chris@0: 
Chris@0: create_admin(_Request) :-
Chris@0: 	(   current_user(_)
Chris@0: 	->  throw(error(permission_error(create, user, admin),
Chris@0: 			context(_, 'Already initialized')))
Chris@0: 	;   true
Chris@0: 	),
Chris@0: 	reply_page('Create administrator',
Chris@0: 		   [ h1(align(center), 'Create administrator'),
Chris@0: 
Chris@0: 		     p('No accounts are available on this server. \
Chris@0: 		        This form allows for creation of an administrative \
Chris@0: 			account that can subsequently be used to create \
Chris@0: 			new users.'),
Chris@0: 
Chris@0: 		     form([ action('../addUser'),
Chris@0: 			    method('GET')
Chris@0: 			  ],
Chris@0: 			  [ \hidden(read, on),
Chris@0: 			    \hidden(write, on),
Chris@0: 			    \hidden(admin, on),
Chris@0: 				    
Chris@0: 			    table([ border(1),
Chris@0: 				    align(center)
Chris@0: 				  ],
Chris@0: 				  [ \input(user, 'Name',
Chris@0: 					   [value('admin')]),
Chris@0: 				    \input(realname, 'Realname',
Chris@0: 					   [value('Administrator')]),
Chris@0: 				    \input(pwd1,     'Password',
Chris@0: 					   [type(password)]),
Chris@0: 				    \input(pwd2,     'Retype',
Chris@0: 					   [type(password)]),
Chris@0: 				    tr(td([ colspan(2),
Chris@0: 					    align(right)
Chris@0: 					  ],
Chris@0: 					  input([ type(submit),
Chris@0: 						  value('Create')
Chris@0: 						])))
Chris@0: 				  ])
Chris@0: 			  ])
Chris@0: 		   ]).
Chris@0: 	
Chris@0: 
Chris@0: %%	add_user_form(+Request)
Chris@0: %	
Chris@0: %	Form to register a user.
Chris@0: 
Chris@0: add_user_form(_Request) :-
Chris@0: 	authorized(admin(add_user)),
Chris@0: 	reply_page('Add new user',
Chris@0: 		   [ \new_user_form
Chris@0: 		   ]).
Chris@0: 
Chris@0: new_user_form -->
Chris@0: 	html([ h1('Add new user'),
Chris@0: 	       form([ action('../addUser'),
Chris@0: 		      method('GET')
Chris@0: 		    ],
Chris@0: 		    table([ border(1)
Chris@0: 			  ],
Chris@0: 			  [ \input(user,     'Name',
Chris@0: 				   []),
Chris@0: 			    \input(realname, 'Realname',
Chris@0: 				   []),
Chris@0: 			    \input(pwd1,     'Password',
Chris@0: 				   [type(password)]),
Chris@0: 			    \input(pwd2,     'Retype',
Chris@0: 				   [type(password)]),
Chris@0: 			    \permissions(-),
Chris@0: 			    tr(td([ colspan(2),
Chris@0: 				    align(right)
Chris@0: 				  ],
Chris@0: 				  input([ type(submit),
Chris@0: 					  value('Create')
Chris@0: 					])))
Chris@0: 			  ]))
Chris@0: 	     ]).
Chris@0: 
Chris@0: 
Chris@0: input(Name, Label, Options) -->
Chris@0: 	html(tr([ td(align(right), Label),
Chris@0: 		  td(input([name(Name),size(40)|Options]))
Chris@0: 		])).
Chris@0: 
Chris@0: %%	add_user(+Request)
Chris@0: %
Chris@0: %	Register a new user.
Chris@0: 
Chris@0: add_user(Request) :-
Chris@0: 	(   \+ current_user(_)
Chris@0: 	->  true
Chris@0: 	;   authorized(admin(add_user))
Chris@0: 	),
Chris@0: 	http_parameters(Request,
Chris@0: 			[ user(User, 	     [ length > 2 ]),
Chris@0: 			  realname(RealName, [ length > 2 ]),
Chris@0: 			  pwd1(Password,     [ length > 5 ]),
Chris@0: 			  pwd2(Retype,       [ length > 5 ]),
Chris@0: 			  read(Read),
Chris@0: 			  write(Write),
Chris@0: 			  admin(Admin)
Chris@0: 			],
Chris@0: 			[ attribute_declarations(attribute_decl)
Chris@0: 			]),
Chris@0: 	(   current_user(User)
Chris@0: 	->  throw(error(permission_error(create, user, User),
Chris@0: 			context(_, 'Already present')))
Chris@0: 	;   true
Chris@0: 	),
Chris@0: 	(   Password == Retype
Chris@0: 	->  true
Chris@0: 	;   throw(password_mismatch)
Chris@0: 	),
Chris@0: 	password_hash(Password, Hash),
Chris@0: 	phrase(allow(Read, Write, Admin), Allow),
Chris@0: 	user_add(User,
Chris@0: 		 [ realname(RealName),
Chris@0: 		   password(Hash),
Chris@0: 		   allow(Allow)
Chris@0: 		 ]),
Chris@0: 	(   User == admin
Chris@0: 	->  user_add(anonymous,
Chris@0: 		     [ realname('Define rights for not-logged in users'),
Chris@0: 		       allow([read(_,_)])
Chris@0: 		     ]),
Chris@0: 	    reply_login([user(User), password(Password)])
Chris@0: 	;   list_users(Request)
Chris@0: 	).
Chris@0: 
Chris@0: %%	edit_user_form(+Request)
Chris@0: %	
Chris@0: %	Form to edit user properties
Chris@0: 
Chris@0: edit_user_form(Request) :-
Chris@0: 	authorized(admin(user(edit))),
Chris@0: 	http_parameters(Request,
Chris@0: 			[ user(User, [])
Chris@0: 			]),
Chris@0: 	
Chris@0: 	www_form_encode(User, Encoded),
Chris@0: 	format(string(Delete), '../delUser?user=~w', [Encoded]),
Chris@0: 	
Chris@0: 	user_property(User, realname(RealName)),
Chris@0: 	
Chris@0: 	reply_page('Edit user',
Chris@0: 		   [ h4(['Edit user ', User, ' (', RealName, ')']),
Chris@0: 		     
Chris@0: 		     form([ action('../editUser'),
Chris@0: 			    method('GET')
Chris@0: 			  ],
Chris@0: 			  [ \hidden(user, User),
Chris@0: 			    table([ border(1),
Chris@0: 				    align(center)
Chris@0: 				  ],
Chris@0: 				  [ \user_property(User,
Chris@0: 						   realname,
Chris@0: 						   'Realname',
Chris@0: 						   []),
Chris@0: 				    \permissions(User),
Chris@0: 				    tr(td([ colspan(2),
Chris@0: 					    align(right)
Chris@0: 					  ],
Chris@0: 					  input([ type(submit),
Chris@0: 						  value('Modify')
Chris@0: 						])))
Chris@0: 				  ])
Chris@0: 			  ]),
Chris@0: 		     
Chris@0: 		     p([ \action(Delete, [ 'Delete ',
Chris@0: 					   b(User),
Chris@0: 					   ' (', b(RealName), ')'
Chris@0: 					 ])
Chris@0: 		       ])
Chris@0: 		   ]).
Chris@0: 	
Chris@0: user_property(User, Name, Label, Options) -->
Chris@0: 	{  Term =.. [Name, Value],
Chris@0: 	   user_property(User, Term)
Chris@0: 	-> O2 = [value(Value)|Options]
Chris@0: 	;  O2 = Options
Chris@0: 	},
Chris@0: 	html(tr([ td(align(right), Label),
Chris@0: 		  td(input([name(Name),size(40)|O2]))
Chris@0: 		])).
Chris@0: 
Chris@0: permissions(User) -->
Chris@0: 	html(tr([ td(align(right), 'Permissions'),
Chris@0: 		  td([ \permission_checkbox(User, read,  'Read'),
Chris@0: 		       \permission_checkbox(User, write, 'Write'),
Chris@0: 		       \permission_checkbox(User, admin, 'Admin')
Chris@0: 		     ])
Chris@0: 		])).
Chris@0: 
Chris@0: permission_checkbox(User, Name, Label) -->
Chris@0: 	{ (   User \== (-),
Chris@0: 	      (	  user_property(User, allow(Actions))
Chris@0: 	      ->  true
Chris@0: 	      ;	  openid_server_property(User, allow(Actions))
Chris@0: 	      ),
Chris@0: 	      pterm(Name, Action),
Chris@0: 	      memberchk(Action, Actions)
Chris@0: 	  ->  Opts = [checked]
Chris@0: 	  ;   Opts = []
Chris@0: 	  )
Chris@0: 	},
Chris@0: 	html([ input([ type(checkbox),
Chris@0: 		       name(Name)
Chris@0: 		     | Opts
Chris@0: 		     ]),
Chris@0: 	       Label
Chris@0: 	     ]).
Chris@0: 
Chris@0: %%	edit_user(Request)
Chris@0: %
Chris@0: %	Handle reply from edit user form.
Chris@0: 
Chris@0: edit_user(Request) :-
Chris@0: 	authorized(admin(user(edit))),
Chris@0: 	http_parameters(Request,
Chris@0: 			[ user(User, []),
Chris@0: 			  realname(RealName,
Chris@0: 				   [ optional(true),
Chris@0: 				     length > 2
Chris@0: 				   ]),
Chris@0: 			  read(Read),
Chris@0: 			  write(Write),
Chris@0: 			  admin(Admin)
Chris@0: 			],
Chris@0: 			[ attribute_declarations(attribute_decl)
Chris@0: 			]),
Chris@0: 	modify_user(User, realname(RealName)),
Chris@0: 	modify_permissions(User, Read, Write, Admin),
Chris@0: 	list_users(Request).
Chris@0: 
Chris@0: 
Chris@0: modify_user(User, Property) :-
Chris@0: 	Property =.. [_Name|Value],
Chris@0: 	(   (   var(Value)
Chris@0: 	    ;	Value == ''
Chris@0: 	    )
Chris@0: 	->  true
Chris@0: 	;   set_user_property(User, Property)
Chris@0: 	).
Chris@0: 
Chris@0: modify_permissions(User, Read, Write, Admin) :-
Chris@0: 	phrase(allow(Read, Write, Admin), Allow),
Chris@0: 	set_user_property(User, allow(Allow)).
Chris@0: 
Chris@0: allow(Read, Write, Admin) -->
Chris@0: 	allow(read, Read),
Chris@0: 	allow(write, Write),
Chris@0: 	allow(admin, Admin).
Chris@0: 
Chris@0: allow(Access, on) -->
Chris@0: 	{ pterm(Access, Allow)
Chris@0: 	}, !,
Chris@0: 	[ Allow
Chris@0: 	].
Chris@0: allow(_Access, off) --> !,
Chris@0: 	[].
Chris@0: 	
Chris@0: pterm(read,  read(_Repositiory, _Action)).
Chris@0: pterm(write, write(_Repositiory, _Action)).
Chris@0: pterm(admin, admin(_Action)).
Chris@0: 
Chris@0: 
Chris@0: %%	del_user(+Request)
Chris@0: %
Chris@0: %	Delete a user
Chris@0: 
Chris@0: del_user(Request) :- !,
Chris@0: 	authorized(admin(del_user)),
Chris@0: 	http_parameters(Request,
Chris@0: 			[ user(User, [])
Chris@0: 			]),
Chris@0: 	(   User == admin
Chris@0: 	->  throw(error(permission_error(delete, user, User), _))
Chris@0: 	;   true
Chris@0: 	),
Chris@0: 	user_del(User),
Chris@0: 	list_users(Request).
Chris@0: 
Chris@0: 			  
Chris@0: %%	change_password_form(+Request)
Chris@0: %	
Chris@0: %	Allow user to change the password
Chris@0: 
Chris@0: change_password_form(_Request) :-
Chris@0: 	logged_on(User),
Chris@0: 	user_property(User, realname(RealName)),
Chris@0: 	reply_page('Change password',
Chris@0: 		   [ h4(['Change password for ', User, ' (', RealName, ')']),
Chris@0: 		     
Chris@0: 		     form([ action('../changePassword'),
Chris@0: 			    method('GET')
Chris@0: 			  ],
Chris@0: 			  [ table([ border(1),
Chris@0: 				    align(center)
Chris@0: 				  ],
Chris@0: 				  [ \user_or_old(User),
Chris@0: 				    \input(pwd1,     'New Password',
Chris@0: 					   [type(password)]),
Chris@0: 				    \input(pwd2,     'Retype',
Chris@0: 					   [type(password)]),
Chris@0: 				    tr(td([ align(right),
Chris@0: 					    colspan(2)
Chris@0: 					  ],
Chris@0: 					  input([ type(submit),
Chris@0: 						  value('Change password')
Chris@0: 						])))
Chris@0: 				  ])
Chris@0: 			  ])
Chris@0: 		   ]).
Chris@0: 
Chris@0: user_or_old(admin) --> !,
Chris@0: 	input(user, 'User', []).
Chris@0: user_or_old(_) -->
Chris@0: 	input(pwd0, 'Old password', [type(password)]).
Chris@0: 
Chris@0: 
Chris@0: %%	change_password(+Request)
Chris@0: %	
Chris@0: %	Actually change the password.  The user must be logged on.
Chris@0: 
Chris@0: change_password(Request) :-
Chris@0: 	logged_on(Login),
Chris@0: 	http_parameters(Request,
Chris@0: 			[ user(User,     [ optional(true) ]),
Chris@0: 			  pwd0(Password, [ optional(true) ]),
Chris@0: 			  pwd1(New,      [ length > 5 ]),
Chris@0: 			  pwd2(Retype,   [ length > 5 ])
Chris@0: 			]),
Chris@0: 	(   Login == admin
Chris@0: 	->  (   current_user(User)
Chris@0: 	    ->	true
Chris@0: 	    ;	throw(error(existence_error(user, User), _))
Chris@0: 	    )
Chris@0: 	;   Login = User,
Chris@0: 	    validate_password(User, Password)
Chris@0: 	),
Chris@0: 	(   New == Retype
Chris@0: 	->  true
Chris@0: 	;   throw(password_mismatch)
Chris@0: 	),
Chris@0: 	password_hash(New, Hash),
Chris@0: 	set_user_property(User, password(Hash)),
Chris@0: 	reply_page('Password changed',
Chris@0: 		   [ h1(align(center), 'Password changed'),
Chris@0: 		     p([ 'Your password has been changed successfully' ])
Chris@0: 		   ]).
Chris@0: 
Chris@0: 
Chris@0: 		 /*******************************
Chris@0: 		 *	       LOGIN		*
Chris@0: 		 *******************************/
Chris@0: 
Chris@0: %%	login_form(+Request)
Chris@0: %
Chris@0: %	HTTP handler that presents a form to login.
Chris@0: 
Chris@0: login_form(_Request) :-
Chris@0: 	reply_page('Login',
Chris@0: 		   [ h1(align(center), 'Login'),
Chris@0: 		     form([ action('../login'),
Chris@0: 			    method('GET')
Chris@0: 			  ],
Chris@0: 			  table([ tr([ th(align(right), 'User:'),
Chris@0: 				       td(input([ name(user),
Chris@0: 						  size(40)
Chris@0: 						]))
Chris@0: 				     ]),
Chris@0: 				  tr([ th(align(right), 'Password:'),
Chris@0: 				       td(input([ type(password),
Chris@0: 						  name(password),
Chris@0: 						  size(40)
Chris@0: 						]))
Chris@0: 				     ]),
Chris@0: 				  tr([ td([ align(right), colspan(2) ],
Chris@0: 					  input([ type(submit),
Chris@0: 						  value('Login')
Chris@0: 						]))
Chris@0: 				     ])
Chris@0: 				])
Chris@0: 			 )
Chris@0: 		   ]).
Chris@0: 
Chris@0: %%	user_login(+Request)
Chris@0: %
Chris@0: %	Handle  =user=  and  =password=.  If    there   is  a  parameter
Chris@0: %	=return_to= or =|openid.return_to|=, reply using   a redirect to
Chris@0: %	the given URL. Otherwise display a welcome page.
Chris@0: 
Chris@0: user_login(Request) :- !,
Chris@0: 	http_parameters(Request,
Chris@0: 			[ user(User, []),
Chris@0: 			  password(Password, []),
Chris@0: 			  'openid.return_to'(ReturnTo, [optional(true)]),
Chris@0: 			  'return_to'(ReturnTo, [optional(true)])
Chris@0: 			]),
Chris@0: 	(   var(ReturnTo)
Chris@0: 	->  Extra = []
Chris@0: 	;   Extra = [ return_to(ReturnTo) ]
Chris@0: 	),
Chris@0: 	reply_login([ user(User),
Chris@0: 		      password(Password)
Chris@0: 		    | Extra
Chris@0: 		    ]).
Chris@0: 
Chris@0: 
Chris@0: reply_login(Options) :-
Chris@0: 	option(user(User), Options),
Chris@0: 	option(password(Password), Options),
Chris@0: 	validate_password(User, Password), !,
Chris@0: 	login(User),
Chris@0: 	(   option(return_to(ReturnTo), Options)
Chris@0: 	->  throw(http_reply(moved_temporary(ReturnTo)))
Chris@0: 	;   reload_attr(sidebar, OnLoad),
Chris@0: 	    reply_page('Login ok',
Chris@0: 		       body([ OnLoad
Chris@0: 			    ],
Chris@0: 			    [ h1(align(center), ['Welcome ', User])
Chris@0: 			    ]))
Chris@0: 	).
Chris@0: reply_login(_) :-
Chris@0: 	reply_page('Login failed',
Chris@0: 		   [ h1(align(center), 'Login failed'),
Chris@0: 		     p(['Password incorrect'])
Chris@0: 		   ]).
Chris@0: 		     
Chris@0: %%	user_logout(+Request)
Chris@0: %
Chris@0: %	Logout the current user
Chris@0: 
Chris@0: user_logout(_Request) :-
Chris@0: 	logged_on(User),
Chris@0: 	logout(User),
Chris@0: 	reload_attr(sidebar, OnLoad),
Chris@0: 	reply_page('Logout',
Chris@0: 		   body([ OnLoad
Chris@0: 			],
Chris@0: 			[ h1(align(center), ['Logged out ', User])
Chris@0: 			])).
Chris@0: 
Chris@0: reload_attr(Frame, onLoad(Script)) :-
Chris@0: 	concat_atom([ 'top.frames[\'', Frame, '\'].location=top.frames[\'',
Chris@0: 		      Frame, '\'].location.href'
Chris@0: 		    ], Script).
Chris@0: 
Chris@0: 
Chris@0: attribute_decl(read,  Options)   :- bool(off, Options).
Chris@0: attribute_decl(write, Options)   :- bool(off, Options).
Chris@0: attribute_decl(admin, Options)   :- bool(off, Options).
Chris@0: 
Chris@0: bool(Def, 
Chris@0:      [ default(Def),
Chris@0:        type(oneof([on, off]))
Chris@0:      ]).
Chris@0: 
Chris@0: 
Chris@0: 		 /*******************************
Chris@0: 		 *	    OPENID ADMIN	*
Chris@0: 		 *******************************/
Chris@0: 
Chris@0: %%	add_openid_server_form(+Request)
Chris@0: %	
Chris@0: %	Register an OpenID server
Chris@0: 
Chris@0: add_openid_server_form(_Request) :-
Chris@0: 	authorized(admin(add_openid_server)),
Chris@0: 	reply_page('Add OpenID server',
Chris@0: 		   [ \new_openid_form
Chris@0: 		   ]).
Chris@0: 
Chris@0: 
Chris@0: %%	new_openid_form// is det.
Chris@0: %
Chris@0: %	Present form to add a new OpenID provider.
Chris@0: 
Chris@0: new_openid_form -->
Chris@0: 	html([ h1('Add new OpenID server'),
Chris@0: 	       form([ action('../addOpenIDServer'),
Chris@0: 		      method('GET')
Chris@0: 		    ],
Chris@0: 		    table([ border(1)
Chris@0: 			  ],
Chris@0: 			  [ \input(openid_server, 'Server homepage', []),
Chris@0: 			    \input(openid_description, 'Server description',
Chris@0: 				   []),
Chris@0: 			    \permissions(-),
Chris@0: 			    tr(td([ colspan(2),
Chris@0: 				    align(right)
Chris@0: 				  ],
Chris@0: 				  input([ type(submit),
Chris@0: 					  value('Create')
Chris@0: 					])))
Chris@0: 			  ])),
Chris@0: 	       p([ 'Use this form to define access rights for users of an ',
Chris@0: 		   a(href('http://www.openid.net'), 'OpenID'), ' server.',
Chris@0: 		   'The special server', code(*), ' specifies access for all OpenID servers.',
Chris@0: 		   'Here are some examples of servers:'
Chris@0: 		 ]),
Chris@0: 	       ul([ li(code('http://myopenid.com')),
Chris@0: 		    li(code('http://videntity.org'))
Chris@0: 		  ])
Chris@0: 	     ]).
Chris@0: 
Chris@0: 
Chris@0: %%	add_openid_server(+Request)
Chris@0: %
Chris@0: %	Allow access from an OpenID server
Chris@0: 
Chris@0: add_openid_server(Request) :-
Chris@0: 	authorized(admin(add_openid_server)),
Chris@0: 	http_parameters(Request,
Chris@0: 			[ openid_server(Server0,          []),
Chris@0: 			  openid_description(Description, [ optional(true) ]),
Chris@0: 			  read(Read),
Chris@0: 			  write(Write)
Chris@0: 			],
Chris@0: 			[ attribute_declarations(attribute_decl)
Chris@0: 			]),
Chris@0: 	phrase(allow(Read, Write, off), Allow),
Chris@0: 	canonical_url(Server0, Server),
Chris@0: 	Options = [ description(Description),
Chris@0: 		    allow(Allow)
Chris@0: 		  ],
Chris@0: 	remove_optional(Options, Properties),
Chris@0: 	openid_add_server(Server, Properties),
Chris@0: 	list_users(Request).
Chris@0: 
Chris@0: remove_optional([], []).
Chris@0: remove_optional([H|T0], [H|T]) :-
Chris@0: 	arg(1, H, A),
Chris@0: 	nonvar(A), !,
Chris@0: 	remove_optional(T0, T).
Chris@0: remove_optional([_|T0], T) :-
Chris@0: 	remove_optional(T0, T).
Chris@0: 
Chris@0: 
Chris@0: canonical_url(Var, Var) :-
Chris@0: 	var(Var), !.
Chris@0: canonical_url(*, *) :- !.
Chris@0: canonical_url(URL0, URL) :-
Chris@0: 	parse_url(URL0, Parts),
Chris@0: 	parse_url(URL, Parts).
Chris@0: 
Chris@0: 
Chris@0: %%	edit_openid_server_form(+Request)
Chris@0: %	
Chris@0: %	Form to edit user properties
Chris@0: 
Chris@0: edit_openid_server_form(Request) :-
Chris@0: 	authorized(admin(openid(edit))),
Chris@0: 	http_parameters(Request,
Chris@0: 			[ openid_server(Server, [])
Chris@0: 			]),
Chris@0: 	
Chris@0: 	www_form_encode(Server, Encoded),
Chris@0: 	format(string(Delete),
Chris@0: 	       '../delOpenIDServer?openid_server=~w', [Encoded]),
Chris@0: 	
Chris@0: 	reply_page('Edit OpenID server',
Chris@0: 		   [ h4(['Edit OpenID server ', Server]),
Chris@0: 		     
Chris@0: 		     form([ action('../editOpenIDServer'),
Chris@0: 			    method('GET')
Chris@0: 			  ],
Chris@0: 			  [ \hidden(openid_server, Server),
Chris@0: 			    table([ border(1)
Chris@0: 				  ],
Chris@0: 				  [ \openid_property(Server, description, 'Description', []),
Chris@0: 				    \permissions(Server),
Chris@0: 				    tr(td([ colspan(2),
Chris@0: 					    align(right)
Chris@0: 					  ],
Chris@0: 					  input([ type(submit),
Chris@0: 						  value('Modify')
Chris@0: 						])))
Chris@0: 				  ])
Chris@0: 			  ]),
Chris@0: 		     
Chris@0: 		     p([ \action(Delete, [ 'Delete ', b(Server) ]) ])
Chris@0: 		   ]).
Chris@0: 
Chris@0: 
Chris@0: openid_property(Server, Name, Label, Options) -->
Chris@0: 	{  Term =.. [Name, Value],
Chris@0: 	   openid_server_property(Server, Term)
Chris@0: 	-> O2 = [value(Value)|Options]
Chris@0: 	;  O2 = Options
Chris@0: 	},
Chris@0: 	html(tr([ td(align(right), Label),
Chris@0: 		  td(input([name(Name),size(40)|O2]))
Chris@0: 		])).
Chris@0: 
Chris@0: 
Chris@0: %%	openid_server_table//
Chris@0: %
Chris@0: %	List registered openid servers
Chris@0: 
Chris@0: openid_server_table -->
Chris@0: 	{ setof(S, openid_current_server(S), Servers), !
Chris@0: 	},
Chris@0: 	html([ table([ border(1)
Chris@0: 		     ],
Chris@0: 		     [ tr([ th('Server'),
Chris@0: 			    th('Description')
Chris@0: 			  ])
Chris@0: 		     | \openid_list_servers(Servers)
Chris@0: 		     ])
Chris@0: 	     ]).
Chris@0: openid_server_table -->
Chris@0: 	[].
Chris@0: 
Chris@0: openid_list_servers([]) -->
Chris@0: 	[].
Chris@0: openid_list_servers([H|T]) -->
Chris@0: 	openid_list_server(H),
Chris@0: 	openid_list_servers(T).
Chris@0: 
Chris@0: openid_list_server(Server) -->
Chris@0: 	{ www_form_encode(Server, Encoded),
Chris@0: 	  format(string(Edit), 'form/editOpenIDServer?openid_server=~w', [Encoded])
Chris@0: 	},
Chris@0: 	html(tr([td(\openid_server(Server)),
Chris@0: 		 td(\openid_field(Server, description)),
Chris@0: 		 td(a(href(Edit), 'Edit'))
Chris@0: 		])).
Chris@0: 
Chris@0: openid_server(*) --> !,
Chris@0: 	html(*).
Chris@0: openid_server(Server) -->
Chris@0: 	html(a(href(Server), Server)).
Chris@0: 
Chris@0: openid_field(Server, Field) -->
Chris@0: 	{ Term =.. [Field, Value],
Chris@0: 	  openid_server_property(Server, Term)
Chris@0: 	}, !,
Chris@0: 	html(Value).
Chris@0: openid_field(_, _) -->
Chris@0: 	[].
Chris@0: 
Chris@0: 
Chris@0: %%	edit_openid_server(Request)
Chris@0: %
Chris@0: %	Handle reply from OpenID server form.
Chris@0: 
Chris@0: edit_openid_server(Request) :-
Chris@0: 	authorized(admin(openid(edit))),
Chris@0: 	http_parameters(Request,
Chris@0: 			[ openid_server(Server, []),
Chris@0: 			  description(Description,
Chris@0: 				      [ optional(true),
Chris@0: 					length > 2
Chris@0: 				      ]),
Chris@0: 			  read(Read),
Chris@0: 			  write(Write),
Chris@0: 			  admin(Admin)
Chris@0: 			],
Chris@0: 			[ attribute_declarations(attribute_decl)
Chris@0: 			]),
Chris@0: 	modify_openid(Server, description(Description)),
Chris@0: 	openid_modify_permissions(Server, Read, Write, Admin),
Chris@0: 	list_users(Request).
Chris@0: 
Chris@0: 
Chris@0: modify_openid(User, Property) :-
Chris@0: 	Property =.. [_Name|Value],
Chris@0: 	(   (   var(Value)
Chris@0: 	    ;	Value == ''
Chris@0: 	    )
Chris@0: 	->  true
Chris@0: 	;   openid_set_property(User, Property)
Chris@0: 	).
Chris@0: 
Chris@0: 
Chris@0: openid_modify_permissions(Server, Read, Write, Admin) :-
Chris@0: 	phrase(allow(Read, Write, Admin), Allow),
Chris@0: 	openid_set_property(Server, allow(Allow)).
Chris@0: 
Chris@0: 
Chris@0: %%	del_openid_server(+Request)
Chris@0: %
Chris@0: %	Delete an OpenID Server
Chris@0: 
Chris@0: del_openid_server(Request) :- !,
Chris@0: 	authorized(admin(openid(delete))),
Chris@0: 	http_parameters(Request,
Chris@0: 			[ openid_server(Server, [])
Chris@0: 			]),
Chris@0: 	openid_del_server(Server),
Chris@0: 	list_users(Request).
Chris@0: 
Chris@0: 
Chris@0: 		 /*******************************
Chris@0: 		 *	       SETTINGS		*
Chris@0: 		 *******************************/
Chris@0: 
Chris@0: %%	settings(+Request)
Chris@0: %
Chris@0: %	Show current settings. Is user is =admin=, allow editing the
Chris@0: %	settings.
Chris@0: 
Chris@0: settings(_Request) :-
Chris@0: 	(   catch(authorized(admin(edit_settings)), _, fail)
Chris@0: 	->  Edit = true
Chris@0: 	;   authorized(read(admin, settings)),
Chris@0: 	    Edit = false
Chris@0: 	),
Chris@0: 	phrase(page([ title('Settings'),
Chris@0: 		      link([ rel(stylesheet),
Chris@0: 			     type('text/css'),
Chris@0: 			     href('../css/settings.css')
Chris@0: 			   ])
Chris@0: 		    ],
Chris@0: 		    [ \http_show_settings([ edit(Edit),
Chris@0: 					    hide_module(false),
Chris@0: 					    action('save_settings')
Chris@0: 					  ])
Chris@0: 		    ]), HTML),
Chris@0: 	format('Content-type: text/html~n~n'),
Chris@0: 	print_html(HTML).
Chris@0: 
Chris@0: %%	save_settings(+Request)
Chris@0: %
Chris@0: %	Save modified settings.
Chris@0: 
Chris@0: save_settings(Request) :-
Chris@0: 	authorized(admin(edit_settings)),
Chris@0: 	phrase(page([ title('Save settings'),
Chris@0: 		      link([ rel(stylesheet),
Chris@0: 			     type('text/css'),
Chris@0: 			     href('../css/settings.css')
Chris@0: 			   ])
Chris@0: 		    ],
Chris@0: 		    [ \http_apply_settings(Request, [save(true)])
Chris@0: 		    ]), HTML),
Chris@0: 	format('Content-type: text/html~n~n'),
Chris@0: 	print_html(HTML).
Chris@0: 
Chris@0: 
Chris@0: 		 /*******************************
Chris@0: 		 *		EMIT		*
Chris@0: 		 *******************************/
Chris@0: 
Chris@0: %%	hidden(+Name, +Value)
Chris@0: %	
Chris@0: %	Create a hidden input field with given name and value
Chris@0: 
Chris@0: hidden(Name, Value) -->
Chris@0: 	html(input([ type(hidden),
Chris@0: 		     name(Name),
Chris@0: 		     value(Value)
Chris@0: 		   ])).
Chris@0: 
Chris@0: 
Chris@0: reply_page(Title, Content) :-
Chris@0: 	phrase(page(title(Title), Content), HTML),
Chris@0: 	format('Content-type: text/html~n~n'),
Chris@0: 	print_html(HTML).
Chris@0: 
Chris@0: %	Support Cross-Referencer and PceEmacs.
Chris@0: 
Chris@0: :- multifile
Chris@0: 	emacs_prolog_colours:goal_colours/2,
Chris@0: 	prolog:called_by/2.
Chris@0: 
Chris@0: 
Chris@0: emacs_prolog_colours:goal_colours(reply_page(_, HTML),
Chris@0: 				  built_in-[classify, Colours]) :-
Chris@0: 	catch(html_write:html_colours(HTML, Colours), _, fail).
Chris@0: prolog:called_by(reply_page(_, HTML), Called) :-
Chris@0: 	catch(phrase(html_write:called_by(HTML), Called), _, fail).