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): 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_openid,
Chris@0: 	  [ openid_login/1,		% +OpenID
Chris@0: 	    openid_logout/1,		% +OpenID
Chris@0: 	    openid_logged_in/1,		% -OpenID
Chris@0: 
Chris@0: 					% transparent login
Chris@0: 	    openid_user/3,		% +Request, -User, +Options
Chris@0: 
Chris@0: 					% low-level primitives
Chris@0: 	    openid_verify/2,		% +Options, +Request
Chris@0: 	    openid_authenticate/4,	% +Request, -Server, -User, -ReturnTo
Chris@0: 	    openid_associate/3,		% +OpenIDServer, -Handle, -Association
Chris@0: 	    openid_server/2,		% +Request
Chris@0: 	    openid_grant/1,		% +Request
Chris@0: 	    openid_file/1,		% +Request (?name=File)
Chris@0: 	    openid_server/3,		% ?OpenIDLogin, ?OpenID, ?Server
Chris@0: 	    
Chris@0: 	    openid_login_form/4,	% +ReturnTo, +Options, //
Chris@0: 	    openid_css/2,		% +Emit link to CSS page
Chris@0: 
Chris@0: 	    openid_current_host/3	% +Request, -Host, -Port
Chris@0: 	  ]).
Chris@0: :- use_module(library('http/http_open')).
Chris@0: :- use_module(library('http/http_client')).
Chris@0: :- use_module(library('http/html_write')).
Chris@0: :- use_module(library('http/http_parameters')).
Chris@0: :- use_module(library('http/http_wrapper')).
Chris@0: :- use_module(library('http/thread_httpd')).
Chris@0: :- use_module(library('http/http_dispatch')).
Chris@0: :- use_module(library('http/http_session')).
Chris@0: :- use_module(library('http/http_host')).
Chris@0: :- use_module(library(utf8)).
Chris@0: :- use_module(library(error)).
Chris@0: :- use_module(library(sgml)).
Chris@0: :- use_module(library(url)).
Chris@0: :- use_module(library(occurs)).
Chris@0: :- use_module(library(base64)).
Chris@0: :- use_module(library(debug)).
Chris@0: :- use_module(library(record)).
Chris@0: :- use_module(library(option)).
Chris@0: :- use_module(library(sha)).
Chris@0: :- use_module(library(socket)).
Chris@0: :- use_module(library(lists)).
Chris@0: 
Chris@0: 
Chris@0: /** <module> OpenID consumer library
Chris@0: 
Chris@0: This library implements the OpenID protocol (http://openid.net/). OpenID
Chris@0: is a protocol to share identities on   the  network. The protocol itself
Chris@0: uses simple basic  HTTP,  adding   reliability  using  digitally  signed
Chris@0: messages.
Chris@0: 
Chris@0: Steps, as seen from the _consumer_ (or _|relying partner|_).
Chris@0: 
Chris@0: 	1. Show login form, asking for =openid_identifier=
Chris@0: 	2. Get HTML page from =openid_identifier= and lookup 
Chris@0: 	   =|<link rel="openid.server" href="server">|=
Chris@0: 	3. Associate to _server_
Chris@0: 	4. Redirect browser (302) to server using mode =checkid_setup=,
Chris@0: 	   asking to validate the given OpenID.
Chris@0: 	5. OpenID server redirects back, providing digitally signed
Chris@0: 	   conformation of the claimed identity.
Chris@0: 	6. Validate signature and redirect to the target location.
Chris@0: 
Chris@0: This module is typically used through openid_user/3.
Chris@0: 
Chris@0: @author	Jan Wielemaker
Chris@0: */
Chris@0: 
Chris@0: %%	openid_hook(+Action)
Chris@0: %
Chris@0: %	Call hook on the OpenID management library.  Defined hooks are:
Chris@0: %	
Chris@0: %		* login(+OpenID)
Chris@0: %		Consider OpenID logged in.
Chris@0: %		
Chris@0: %		* logout(+OpenID)
Chris@0: %		Logout OpenID
Chris@0: %		
Chris@0: %		* logged_in(?OpenID)
Chris@0: %		True if OpenID is logged in
Chris@0: %		
Chris@0: %		* grant(+Request, +Options)
Chris@0: %		Server: Reply positive on OpenID
Chris@0: %		
Chris@0: %		* trusted_server(?Server)
Chris@0: %		True if Server is a trusted OpenID server
Chris@0: 
Chris@0: :- multifile
Chris@0: 	openid_hook/1.			% +Action
Chris@0: 
Chris@0: 		 /*******************************
Chris@0: 		 *	 DIRECT LOGIN/OUT	*
Chris@0: 		 *******************************/
Chris@0: 
Chris@0: %%	openid_login(+OpenID) is det.
Chris@0: %
Chris@0: %	Associate the current  HTTP  session   with  OpenID.  If another
Chris@0: %	OpenID is already associated, this association is first removed.
Chris@0: 
Chris@0: openid_login(OpenID) :-
Chris@0: 	openid_hook(login(OpenID)), !.
Chris@0: openid_login(OpenID) :-
Chris@0: 	openid_logout(_),
Chris@0: 	http_session_assert(openid(OpenID)).
Chris@0: 
Chris@0: %%	openid_logout(+OpenID) is det.
Chris@0: %
Chris@0: %	Remove the association of the current session with any OpenID
Chris@0: 
Chris@0: openid_logout(OpenID) :-
Chris@0: 	openid_hook(logout(OpenID)), !.
Chris@0: openid_logout(OpenID) :-
Chris@0: 	http_session_retractall(openid(OpenID)).
Chris@0: 
Chris@0: %%	openid_logged_in(-OpenID) is semidet.
Chris@0: %
Chris@0: %	True if session is associated with OpenID.
Chris@0: 
Chris@0: openid_logged_in(OpenID) :-
Chris@0: 	openid_hook(logged_in(OpenID)), !.
Chris@0: openid_logged_in(OpenID) :-
Chris@0: 	http_session_data(openid(OpenID)).
Chris@0: 
Chris@0: 
Chris@0: 		 /*******************************
Chris@0: 		 *	      TOPLEVEL		*
Chris@0: 		 *******************************/
Chris@0: 
Chris@0: %%	openid_user(+Request:http_request, -OpenID:url, +Options) is det.
Chris@0: %
Chris@0: %	True if OpenID is a validated OpenID associated with the current
Chris@0: %	session. The scenario for which this predicate is designed is to
Chris@0: %	allow  an  HTTP  handler  that  requires    a   valid  login  to
Chris@0: %	use the transparent code below. 
Chris@0: %	
Chris@0: %	==
Chris@0: %	handler(Request) :-
Chris@0: %		openid_user(Request, OpenID, []),
Chris@0: %		...
Chris@0: %	==
Chris@0: %	
Chris@0: %	If the user is not yet logged on a sequence of redirects will
Chris@0: %	follow:
Chris@0: %	
Chris@0: %		1. Show a page for login (default: page /openid/login),
Chris@0: %		   predicate reply_openid_login/1)
Chris@0: %		2. Redirect to OpenID server to validate
Chris@0: %		3. Redirect to validation
Chris@0: %		
Chris@0: %	Options:
Chris@0: %	
Chris@0: %		* login_url(Login)
Chris@0: %		(Local) URL of page to enter OpenID information. Default
Chris@0: %		is =|/openid/login|=.
Chris@0: %	
Chris@0: %	@see openid_authenticate/4 produces errors if login is invalid
Chris@0: %	or cancelled.
Chris@0: 
Chris@0: :- http_handler('/openid/login',  openid_login_page, []).
Chris@0: :- http_handler('/openid/verify', openid_verify([]), []).
Chris@0: 
Chris@0: openid_user(_Request, OpenID, _Options) :-
Chris@0: 	openid_logged_in(OpenID), !.
Chris@0: openid_user(Request, User, _Options) :-
Chris@0: 	openid_authenticate(Request, _OpenIdServer, OpenID, _ReturnTo), !,
Chris@0: 	openid_server(User, OpenID, _),
Chris@0: 	openid_login(User).
Chris@0: openid_user(Request, _OpenID, Options) :-
Chris@0: 	option(login_url(Login), Options, '/openid/login'),
Chris@0: 	current_url(Request, Here),
Chris@0: 	redirect_browser(Login,
Chris@0: 			 [ 'openid.return_to' = Here 
Chris@0: 			 ]).
Chris@0: 
Chris@0: 
Chris@0: %%	openid_login_page(+Request) is det.
Chris@0: %
Chris@0: %	Present a login-form for OpenID. There  are two ways to redefine
Chris@0: %	this  default  login  page.  One  is    to  provide  the  option
Chris@0: %	=login_url= to openid_user/3 and the other   is  to define a new
Chris@0: %	handler for =|/openid/login|= using http_handler/3.
Chris@0: %	
Chris@0: %	@tbd	Add CSS to page
Chris@0: %	@tbd	Use http_current_handler/2 to make the link more dynamic.
Chris@0: 
Chris@0: openid_login_page(Request) :-
Chris@0: 	http_parameters(Request,
Chris@0: 			[ 'openid.return_to'(ReturnTo, [])
Chris@0: 			]),
Chris@0: 	reply_html_page([ title('OpenID login'),
Chris@0: 			  \openid_css
Chris@0: 			],
Chris@0: 			[ \openid_login_form(ReturnTo, [])
Chris@0: 			]).
Chris@0: 
Chris@0: %%	openid_css// is det.
Chris@0: %
Chris@0: %	Emit a link to the OpenID CSS file.
Chris@0: 
Chris@0: openid_css -->
Chris@0: 	html(link([ rel(stylesheet),
Chris@0: 		    type('text/css'),
Chris@0: 		    href('file?name=openid_css')
Chris@0: 		  ])).
Chris@0: 
Chris@0: %%	openid_login_form(+ReturnTo, +Options)// is det.
Chris@0: %
Chris@0: %	Create the OpenID  form.  This  exported   as  a  seperate  DCG,
Chris@0: %	allowing applications to redefine /openid/login   and reuse this
Chris@0: %	part of the page.
Chris@0: 
Chris@0: openid_login_form(ReturnTo, Options) -->
Chris@0: 	{ option(action(Action), Options, verify)
Chris@0: 	},
Chris@0: 	html(div(class('openid-login'),
Chris@0: 		 [ \openid_title,
Chris@0: 		   form([ name(login),
Chris@0: 			  action(Action),
Chris@0: 			  method('GET')
Chris@0: 			],
Chris@0: 			[ \hidden('openid.return_to', ReturnTo),
Chris@0: 			  div([ input([ class('openid-input'),
Chris@0: 					name(openid_url),
Chris@0: 					size(30)
Chris@0: 				      ]),
Chris@0: 				input([ type(submit),
Chris@0: 					value('Verify!')
Chris@0: 				      ])
Chris@0: 			      ])
Chris@0: 			])
Chris@0: 		 ])).
Chris@0: 
Chris@0: 
Chris@0: 
Chris@0: 		 /*******************************
Chris@0: 		 *	    HTTP REPLIES	*
Chris@0: 		 *******************************/
Chris@0: 
Chris@0: %%	openid_verify(+Options, +Request)
Chris@0: %
Chris@0: %	Handle the initial login  form  presented   to  the  user by the
Chris@0: %	relying party (consumer). This predicate   discovers  the OpenID
Chris@0: %	server, associates itself with  this   server  and redirects the
Chris@0: %	user's  browser  to  the  OpenID  server,  providing  the  extra
Chris@0: %	openid.X name-value pairs. Options is,  against the conventions,
Chris@0: %	placed in front of the Request   to allow for smooth cooperation
Chris@0: %	with http_dispatch.pl.
Chris@0: %	
Chris@0: %	The OpenId server will redirect to the openid.return_to URL.
Chris@0: %	
Chris@0: %	@throws	http_reply(moved_temporary(Redirect))
Chris@0: 
Chris@0: openid_verify(Options, Request) :-
Chris@0: 	http_parameters(Request,
Chris@0: 			[ openid_url(URL, [length>1]),
Chris@0: 			  'openid.return_to'(ReturnTo0, [optional(true)])
Chris@0: 			]),
Chris@0: 	(   option(return_to(ReturnTo1), Options)		% Option
Chris@0: 	->  current_url(Request, CurrentLocation),
Chris@0: 	    global_url(ReturnTo1, CurrentLocation, ReturnTo)
Chris@0: 	;   nonvar(ReturnTo0)
Chris@0: 	->  ReturnTo = ReturnTo0				% Form-data
Chris@0: 	;   current_url(Request, CurrentLocation),
Chris@0: 	    ReturnTo = CurrentLocation				% Current location
Chris@0: 	),
Chris@0: 	current_root_url(Request, CurrentRoot),
Chris@0: 	option(trust_root(TrustRoot), Options, CurrentRoot),
Chris@0: 	openid_resolve(URL, OpenIDLogin, OpenID, Server),
Chris@0: 	trusted(OpenID, Server),
Chris@0: 	openid_associate(Server, Handle, _Assoc),
Chris@0: 	assert_openid(OpenIDLogin, OpenID, Server),
Chris@0: 	redirect_browser(Server, [ 'openid.mode'         = checkid_setup,
Chris@0: 				   'openid.identity'     = OpenID,
Chris@0: 				   'openid.assoc_handle' = Handle,
Chris@0: 				   'openid.return_to'    = ReturnTo,
Chris@0: 				   'openid.trust_root'   = TrustRoot
Chris@0: 				 ]).
Chris@0: 			
Chris@0: 
Chris@0: %%	assert_openid(+OpenIDLogin, +OpenID, +Server) is det.
Chris@0: %
Chris@0: %	Associate the OpenID  as  typed  by   the  user,  the  OpenID as
Chris@0: %	validated by the Server with the current HTTP session.
Chris@0: %
Chris@0: %	@param OpenIDLogin Canonized OpenID typed by user
Chris@0: %	@param OpenID OpenID verified by Server.
Chris@0: 
Chris@0: assert_openid(OpenIDLogin, OpenID, Server) :-
Chris@0: 	http_session_assert(openid_login(OpenIDLogin, OpenID, Server)).
Chris@0: 
Chris@0: %%	openid_server(?OpenIDLogin, ?OpenID, ?Server) is nondet.
Chris@0: %
Chris@0: %	True if OpenIDLogin is the typed id for OpenID verified by
Chris@0: %	Server.
Chris@0: %	
Chris@0: %	@param OpenIDLogin ID as typed by user (canonized)
Chris@0: %	@param OpenID ID as verified by server
Chris@0: %	@param Server URL of the OpenID server
Chris@0: 
Chris@0: openid_server(OpenIDLogin, OpenID, Server) :-
Chris@0: 	http_session_data(openid_login(OpenIDLogin, OpenID, Server)), !.
Chris@0: 
Chris@0: 
Chris@0: %%	current_url(+Request, -Root) is det.
Chris@0: %%	current_root_url(+Request, -Root) is det.
Chris@0: %
Chris@0: %	Return URL of current request or current root.
Chris@0: 
Chris@0: current_root_url(Request, Root) :-
Chris@0: 	openid_current_host(Request, Host, Port),
Chris@0: 	parse_url(Root, [protocol(http), host(Host), port(Port), path(/)]).
Chris@0: 
Chris@0: current_url(Request, URL) :-
Chris@0: 	openid_current_host(Request, Host, Port),
Chris@0: 	(   option(x_redirected_path(Path), Request)
Chris@0: 	->  true
Chris@0: 	;   option(path(Path), Request, /)
Chris@0: 	),
Chris@0: 	option(search(Search), Request, []),
Chris@0: 	parse_url(URL, [ protocol(http), host(Host), port(Port),
Chris@0: 			 path(Path), search(Search)
Chris@0: 		       ]).
Chris@0: 
Chris@0: %%	openid_current_host(Request, Host, Port)
Chris@0: %
Chris@0: %	Find current location of the server.
Chris@0: 
Chris@0: openid_current_host(Request, Host, Port) :-
Chris@0: 	http_current_host(Request, Host, Port,
Chris@0: 			  [ global(true)
Chris@0: 			  ]).
Chris@0: 
Chris@0: 
Chris@0: %%	redirect_browser(+URL, +FormExtra)
Chris@0: %
Chris@0: %	Generate a 302 temporary redirect to  URL, adding the extra form
Chris@0: %	information from FormExtra. The specs says   we  must retain the
Chris@0: %	search specification already attached to the URL.
Chris@0: 
Chris@0: redirect_browser(URL, FormExtra) :-
Chris@0: 	is_absolute_url(URL), !,
Chris@0: 	parse_url(URL, Parts0),
Chris@0: 	(   select(search(List), Parts0, Parts1)
Chris@0: 	->  append(List, FormExtra, Search),
Chris@0: 	    Parts = [search(Search)|Parts1]
Chris@0: 	;   Parts = [search(FormExtra)|Parts0]
Chris@0: 	),
Chris@0: 	parse_url(Redirect, Parts),
Chris@0: 	throw(http_reply(moved_temporary(Redirect))).
Chris@0: redirect_browser(Location, FormExtra) :-
Chris@0: 	http_location(Parts0, Location),
Chris@0: 	(   select(search(List), Parts0, Parts1)
Chris@0: 	->  append(List, FormExtra, Search),
Chris@0: 	    Parts = [search(Search)|Parts1]
Chris@0: 	;   Parts = [search(FormExtra)|Parts0]
Chris@0: 	),
Chris@0: 	http_location(Parts, Redirect),
Chris@0: 	throw(http_reply(moved_temporary(Redirect))).
Chris@0: 
Chris@0: 
Chris@0: 		 /*******************************
Chris@0: 		 *	       RESOLVE		*
Chris@0: 		 *******************************/
Chris@0: 
Chris@0: %%	openid_resolve(+URL, -OpenIDOrig, -OpenID, -Server)
Chris@0: %
Chris@0: %	True if OpenID is the claimed  OpenID   that  belongs to URL and
Chris@0: %	Server is the URL of the  OpenID   server  that  can be asked to
Chris@0: %	verify this claim.
Chris@0: %	
Chris@0: %	@param  URL The OpenID typed by the user
Chris@0: %	@param	OpenIDOrig Canonized OpenID typed by user
Chris@0: %	@param	OpenID Possibly delegated OpenID
Chris@0: %	@param  Server OpenID server that must validate OpenID
Chris@0: %	
Chris@0: %	@tbd	Implement complete URL canonization as defined by the
Chris@0: %		OpenID 2.0 proposal.
Chris@0: 
Chris@0: openid_resolve(URL, OpenID0, OpenID, Server) :-
Chris@0: 	debug(openid(resolve), 'Opening ~w ...', [URL]),
Chris@0: 	http_open(URL, Stream,
Chris@0: 		  [ final_url(OpenID0)
Chris@0: 		  ]),
Chris@0: 	dtd(html, DTD),
Chris@0: 	call_cleanup(load_structure(Stream, Term,
Chris@0: 				    [ dtd(DTD),
Chris@0: 				      dialect(sgml),
Chris@0: 				      shorttag(false),
Chris@0: 				      syntax_errors(quiet)
Chris@0: 				    ]),
Chris@0: 		     close(Stream)),
Chris@0: 	debug(openid(resolve), 'Scanning HTML document ...', [URL]),
Chris@0: 	contains_term(element(head, _, Head), Term),
Chris@0: 	(   link(Head, 'openid.server', Server)
Chris@0: 	->  debug(openid(resolve), 'OpenID Server=~q', [Server])
Chris@0: 	;   debug(openid(resolve), 'No server in ~q', [Head]),
Chris@0: 	    fail
Chris@0: 	),
Chris@0: 	(   link(Head, 'openid.delegate', OpenID)
Chris@0: 	->  debug(openid(resolve), 'OpenID = ~q (delegated)', [OpenID])
Chris@0: 	;   OpenID = OpenID0,
Chris@0: 	    debug(openid(resolve), 'OpenID = ~q', [OpenID])
Chris@0: 	).
Chris@0: 	
Chris@0: 
Chris@0: link(DOM, Type, Target) :-
Chris@0: 	sub_term(element(link, Attrs, []), DOM),
Chris@0: 	memberchk(rel=Type, Attrs),
Chris@0: 	memberchk(href=Target, Attrs).
Chris@0: 
Chris@0: 
Chris@0: 		 /*******************************
Chris@0: 		 *	   AUTHENTICATE		*
Chris@0: 		 *******************************/
Chris@0: 
Chris@0: 
Chris@0: %%	openid_authenticate(+Request, -Server:url, -OpenID:url,
Chris@0: %%			    -ReturnTo:url) is semidet.
Chris@0: %
Chris@0: %	Succeeds if Request comes from the   OpenID  server and confirms
Chris@0: %	that User is a verified OpenID   user. ReturnTo provides the URL
Chris@0: %	to return to.
Chris@0: %	
Chris@0: %	After openid_verify/2 has redirected the   browser to the OpenID
Chris@0: %	server, and the OpenID server did   its  magic, it redirects the
Chris@0: %	browser back to this address.  The   work  is fairly trivial. If
Chris@0: %	=mode= is =cancel=, the OpenId server   denied. If =id_res=, the
Chris@0: %	OpenId server replied positive, but  we   must  verify  what the
Chris@0: %	server tells us by checking the HMAC-SHA signature.
Chris@0: %	
Chris@0: %	This call fails silently if their is no =|openid.mode|= field in
Chris@0: %	the request.
Chris@0: %	
Chris@0: %	@throws	openid(cancel)
Chris@0: %		if request was cancelled by the OpenId server
Chris@0: %	@throws openid(signature_mismatch)
Chris@0: %		if the HMAC signature check failed
Chris@0: 
Chris@0: openid_authenticate(Request, OpenIdServer, Identity, ReturnTo) :-
Chris@0: 	http_parameters(Request,
Chris@0: 			[ 'openid.mode'(Mode, [optional(true)])
Chris@0: 			]),
Chris@0: 	(   var(Mode)
Chris@0: 	->  fail
Chris@0: 	;   Mode == cancel
Chris@0: 	->  throw(openid(cancel))
Chris@0: 	;   Mode == id_res
Chris@0: 	->  http_parameters(Request,
Chris@0: 			    [ 'openid.identity'(Identity, []),
Chris@0: 			      'openid.assoc_handle'(Handle, []),
Chris@0: 			      'openid.return_to'(ReturnTo, []),
Chris@0: 			      'openid.signed'(AtomFields, []),
Chris@0: 			      'openid.sig'(Base64Signature, []),
Chris@0: 			      'openid.invalidate_handle'(Invalidate,
Chris@0: 							 [optional(true)])
Chris@0: 			    ],
Chris@0: 			    [ form_data(Form)
Chris@0: 			    ]),
Chris@0: 	    concat_atom(SignedFields, ',', AtomFields),
Chris@0: 	    check_obligatory_fields(SignedFields),
Chris@0: 	    signed_pairs(SignedFields,
Chris@0: 			 [ mode-Mode,
Chris@0: 			   identity-Identity,
Chris@0: 			   assoc_handle-Handle,
Chris@0: 			   return_to-ReturnTo,
Chris@0: 			   invalidate_handle-Invalidate
Chris@0: 			 ],
Chris@0: 			 Form,
Chris@0: 			 SignedPairs),
Chris@0: 	    (	openid_associate(OpenIdServer, Handle, Assoc)
Chris@0: 	    ->  signature(SignedPairs, Assoc, Sig)
Chris@0: 	    ;	existence_error(assoc_handle, Handle)
Chris@0: 	    ),
Chris@0: 
Chris@0: 	    atom_codes(Base64Signature, Base64SigCodes),
Chris@0: 	    phrase(base64(Signature), Base64SigCodes),
Chris@0: 	    (	Sig == Signature
Chris@0: 	    ->	true
Chris@0: 	    ;	throw(openid(signature_mismatch))
Chris@0: 	    )
Chris@0: 	).
Chris@0: 
Chris@0: %%	signed_pairs(+FieldNames, +Pairs:list(Field-Value), +Form, -SignedPairs) is det.
Chris@0: %
Chris@0: %	Extract the signed field in the order they appear in FieldNames.
Chris@0: 
Chris@0: signed_pairs([], _, _, []).
Chris@0: signed_pairs([Field|T0], Pairs, Form, [Field-Value|T]) :-
Chris@0: 	memberchk(Field-Value, Pairs), !,
Chris@0: 	signed_pairs(T0, Pairs, Form, T).
Chris@0: signed_pairs([Field|T0], Pairs, Form, [Field-Value|T]) :-
Chris@0: 	atom_concat('openid.', Field, OpenIdField),
Chris@0: 	memberchk(OpenIdField=Value, Form), !,
Chris@0: 	signed_pairs(T0, Pairs, Form, T).
Chris@0: signed_pairs([Field|T0], Pairs, Form, T) :-
Chris@0: 	format(user_error, 'Form = ~p~n', [Form]),
Chris@0: 	throw(error(existence_error(field, Field),
Chris@0: 		    context(_, 'OpenID Signed field is not present'))),
Chris@0: 	signed_pairs(T0, Pairs, Form, T).
Chris@0: 
Chris@0: 
Chris@0: %%	check_obligatory_fields(+SignedFields:list) is det.
Chris@0: %
Chris@0: %	Verify fields from obligatory_field/1 are   in  the signed field
Chris@0: %	list.
Chris@0: %
Chris@0: %	@error	existence_error(field, Field)
Chris@0: 
Chris@0: check_obligatory_fields(Fields) :-
Chris@0: 	(   obligatory_field(Field),
Chris@0: 	    (	memberchk(Field, Fields)
Chris@0: 	    ->	true
Chris@0: 	    ;	throw(error(existence_error(field, Field),
Chris@0: 			    context(_, 'OpenID field is not in signed fields')))
Chris@0: 	    ),
Chris@0: 	    fail
Chris@0: 	;   true
Chris@0: 	).
Chris@0: 
Chris@0: obligatory_field(identity).
Chris@0: 
Chris@0: 
Chris@0: 		 /*******************************
Chris@0: 		 *	   OPENID SERVER	*
Chris@0: 		 *******************************/
Chris@0: 
Chris@0: :- dynamic
Chris@0: 	server_association/3.		% URL, Handle, Term
Chris@0: 
Chris@0: %%	openid_server(+Options, +Request)
Chris@0: %
Chris@0: %	Realise the OpenID server. The protocol   demands a POST request
Chris@0: %	here.
Chris@0: 
Chris@0: openid_server(Options, Request) :-
Chris@0: 	http_parameters(Request,
Chris@0: 			[ 'openid.mode'(Mode)
Chris@0: 			],
Chris@0: 			[ attribute_declarations(openid_attribute),
Chris@0: 			  form_data(Form)
Chris@0: 			]),
Chris@0: 	(   Mode == associate
Chris@0: 	->  associate_server(Request, Form, Options)
Chris@0: 	;   Mode == checkid_setup
Chris@0: 	->  checkid_setup_server(Request, Form, Options)
Chris@0: 	).
Chris@0: 			
Chris@0: %%	associate_server(+Request, +Form, +Options)
Chris@0: %
Chris@0: %	Handle the association-request. If successful,   create a clause
Chris@0: %	for server_association/3 to record the current association.
Chris@0: 
Chris@0: associate_server(Request, Form, Options) :-
Chris@0: 	memberchk('openid.assoc_type'	      =	AssocType,   Form),
Chris@0: 	memberchk('openid.session_type'	      =	SessionType, Form),
Chris@0: 	memberchk('openid.dh_modulus'	      =	P64, 	     Form),
Chris@0: 	memberchk('openid.dh_gen'	      =	G64, 	     Form),
Chris@0: 	memberchk('openid.dh_consumer_public' =	CPX64,       Form),
Chris@0: 	base64_btwoc(P, P64),
Chris@0: 	base64_btwoc(G, G64),
Chris@0: 	base64_btwoc(CPX, CPX64),
Chris@0: 	dh_x(P, Y),			% Our secret
Chris@0: 	DiffieHellman is powm(CPX, Y, P),
Chris@0: 	btwoc(DiffieHellman, DHBytes),
Chris@0: 	sha_hash(DHBytes, SHA1, [algorithm(sha1)]),
Chris@0: 	CPY is powm(G, Y, P),
Chris@0: 	base64_btwoc(CPY, CPY64),
Chris@0: 	new_assoc_handle(Handle),
Chris@0: 	random_bytes(20, MacKey),
Chris@0: 	xor_codes(MacKey, SHA1, EncKey),
Chris@0: 	phrase(base64(EncKey), Base64EncKey),
Chris@0: 	DefExpriresIn is 24*3600,
Chris@0: 	option(expires_in(ExpriresIn), Options, DefExpriresIn),
Chris@0: 
Chris@0: 	get_time(Now),
Chris@0: 	ExpiresAt is integer(Now+ExpriresIn),
Chris@0: 	make_association([ session_type(SessionType),
Chris@0: 			   expires_at(ExpiresAt),
Chris@0: 			   mac_key(MacKey)
Chris@0: 			 ],
Chris@0: 			 Record),
Chris@0: 	memberchk(peer(Peer), Request),
Chris@0: 	assert(server_association(Peer, Handle, Record)),
Chris@0: 
Chris@0: 	key_values_data([ assoc_type-AssocType,
Chris@0: 			  assoc_handle-Handle,
Chris@0: 			  expires_in-ExpriresIn,
Chris@0: 			  session_type-SessionType,
Chris@0: 			  dh_server_public-CPY64,
Chris@0: 			  enc_mac_key-Base64EncKey
Chris@0: 			],
Chris@0: 			Text),
Chris@0: 	format('Content-type: text/plain~n~n~s', [Text]).
Chris@0: 
Chris@0: 
Chris@0: new_assoc_handle(Handle) :-
Chris@0: 	random_bytes(20, Bytes),
Chris@0: 	phrase(base64(Bytes), HandleCodes),
Chris@0: 	atom_codes(Handle, HandleCodes).
Chris@0: 
Chris@0: 
Chris@0: %%	checkid_setup_server(+Request, +Form, +Options)
Chris@0: %
Chris@0: %	Validate an OpenID for a TrustRoot and redirect the browser back
Chris@0: %	to the ReturnTo argument.  There   are  many  possible scenarios
Chris@0: %	here:
Chris@0: %	
Chris@0: %		1. Check some cookie and if present, grant immediately
Chris@0: %		2. Use a 401 challenge page
Chris@0: %		3. Present a normal grant/password page
Chris@0: %		4. As (3), but use HTTPS for the exchange
Chris@0: %		5. etc.
Chris@0: %		
Chris@0: %	First thing to check is the immediate acknowledgement.
Chris@0: 
Chris@0: checkid_setup_server(_Request, Form, _Options) :-
Chris@0: 	memberchk('openid.identity'	= Identity,  Form),
Chris@0: 	memberchk('openid.assoc_handle'	= Handle,    Form),
Chris@0: 	memberchk('openid.return_to'	= ReturnTo,  Form),
Chris@0: 	memberchk('openid.trust_root'	= TrustRoot, Form),
Chris@0: 
Chris@0: 	server_association(_, Handle, _Association), 		% check 
Chris@0: 
Chris@0: 	reply_html_page([ title('OpenID login'),
Chris@0: 			  \openid_css
Chris@0: 			],
Chris@0: 			[ \openid_title,
Chris@0: 			  div(class('openid-message'),
Chris@0: 			      ['Site ', a(href(TrustRoot), TrustRoot), ' requests permission \
Chris@0: 			       to login with OpenID ', a(href(Identity), Identity), '.'
Chris@0: 			      ]),
Chris@0: 			  table(class('openid-form'),
Chris@0: 				[ tr(td(form([ action(grant), method('GET') ],
Chris@0: 					     [ \hidden('openid.grant', yes),
Chris@0: 					       \hidden('openid.identity', Identity),
Chris@0: 					       \hidden('openid.assoc_handle', Handle),
Chris@0: 					       \hidden('openid.return_to', ReturnTo),
Chris@0: 					       \hidden('openid.trust_root', TrustRoot),
Chris@0: 					       div(['Password: ',
Chris@0: 						    input([type(password), name('openid.password')]),
Chris@0: 						    input([type(submit), value('Grant')])
Chris@0: 						   ])
Chris@0: 					     ]))),
Chris@0: 				  tr(td(align(right),
Chris@0: 					form([ action(grant), method('GET') ],
Chris@0: 					     [ \hidden('openid.grant', no),
Chris@0: 					       \hidden('openid.return_to', ReturnTo),
Chris@0: 					       input([type(submit), value('Deny')])
Chris@0: 					     ])))
Chris@0: 				])
Chris@0: 			]).
Chris@0: 
Chris@0: hidden(Name, Value) -->
Chris@0: 	html(input([type(hidden), name(Name), value(Value)])).
Chris@0: 
Chris@0: 
Chris@0: openid_title -->
Chris@0: 	html(div(class('openid-title'),
Chris@0: 		 [ a(href('http://openid.net/'),
Chris@0: 		     img([ src('file?name=openid_logo'), alt('OpenID') ])),
Chris@0: 		   span('Login')
Chris@0: 		 ])).
Chris@0: 
Chris@0: 
Chris@0: %%	openid_grant(+Request)
Chris@0: %
Chris@0: %	Handle the reply from checkid_setup_server/3.   If  the reply is
Chris@0: %	=yes=, check the authority (typically the   password) and if all
Chris@0: %	looks good redirect the browser to   ReturnTo, adding the OpenID
Chris@0: %	properties needed by the Relying Party to verify the login.
Chris@0: 
Chris@0: openid_grant(Request) :-
Chris@0: 	http_parameters(Request,
Chris@0: 			[ 'openid.grant'(Grant),
Chris@0: 			  'openid.return_to'(ReturnTo)
Chris@0: 			],
Chris@0: 			[ attribute_declarations(openid_attribute)
Chris@0: 			]),
Chris@0: 	(   Grant == yes
Chris@0: 	->  http_parameters(Request,
Chris@0: 			    [ 'openid.identity'(Identity),
Chris@0: 			      'openid.assoc_handle'(Handle),
Chris@0: 			      'openid.trust_root'(TrustRoot),
Chris@0: 			      'openid.password'(Password)
Chris@0: 			    ],
Chris@0: 			    [ attribute_declarations(openid_attribute)
Chris@0: 			    ]),
Chris@0: 	    server_association(_, Handle, Association),
Chris@0: 	    grant_login(Request,
Chris@0: 			[ identity(Identity),
Chris@0: 			  password(Password),
Chris@0: 			  trustroot(TrustRoot)
Chris@0: 			]),
Chris@0: 	    SignedPairs = [ 'mode'-id_res,
Chris@0: 			    'identity'-Identity,
Chris@0: 			    'assoc_handle'-Handle,
Chris@0: 			    'return_to'-ReturnTo
Chris@0: 			  ],
Chris@0: 	    signed_fields(SignedPairs, Signed),
Chris@0: 	    signature(SignedPairs, Association, Signature),
Chris@0: 	    phrase(base64(Signature), Bas64Sig),
Chris@0: 	    redirect_browser(ReturnTo,
Chris@0: 			     [ 'openid.mode' = id_res,
Chris@0: 			       'openid.identity' = Identity,
Chris@0: 			       'openid.assoc_handle' = Handle,
Chris@0: 			       'openid.return_to' = ReturnTo,
Chris@0: 			       'openid.signed' = Signed,
Chris@0: 			       'openid.sig' = Bas64Sig
Chris@0: 			     ])
Chris@0: 	;    redirect_browser(ReturnTo,
Chris@0: 			     [ 'openid.mode' = cancel
Chris@0: 			     ])
Chris@0: 	).
Chris@0: 	    
Chris@0: 
Chris@0: %%	grant_login(+Request, +Options) is det.
Chris@0: %
Chris@0: %	Validate login from Request (can  be   used  to get cookies) and
Chris@0: %	Options, which contains at least:
Chris@0: %	
Chris@0: %		* identity(Identity)
Chris@0: %		* password(Password)
Chris@0: %		* trustroot(TrustRoot)
Chris@0: 
Chris@0: grant_login(Request, Options) :-
Chris@0: 	openid_hook(grant(Request, Options)).
Chris@0: 
Chris@0: %%	trusted(+OpenID, +Server)
Chris@0: %
Chris@0: %	True if we  trust  the  given   OpenID  server.  Must  throw  an
Chris@0: %	exception, possibly redirecting to a   page with trusted servers
Chris@0: %	if the given server is not trusted.
Chris@0: %	
Chris@0: %	@tbd	How do we manage this?  Broadcast?  Settings?  Hook?
Chris@0: 
Chris@0: trusted(OpenID, Server) :-
Chris@0: 	openid_hook(trusted(OpenID, Server)).
Chris@0: 
Chris@0: 
Chris@0: %%	signed_fields(+Pairs, -Signed) is det.
Chris@0: %
Chris@0: %	Create a comma-separated  atom  from   the  field-names  without
Chris@0: %	'openid.' from Pairs.
Chris@0: 
Chris@0: signed_fields(Pairs, Signed) :-
Chris@0: 	signed_field_names(Pairs, Names),
Chris@0: 	concat_atom(Names, ',', Signed).
Chris@0: 
Chris@0: signed_field_names([], []).
Chris@0: signed_field_names([H0-_|T0], [H|T]) :-
Chris@0: 	(   atom_concat('openid.', H, H0)
Chris@0: 	->  true
Chris@0: 	;   H = H0
Chris@0: 	),
Chris@0: 	signed_field_names(T0, T).
Chris@0: 
Chris@0: %%	signature(+Pairs, +Association, -Signature)
Chris@0: %
Chris@0: %	Determine the signature for Pairs
Chris@0: 
Chris@0: signature(Pairs, Association, Signature) :-
Chris@0: 	key_values_data(Pairs, TokenContents),
Chris@0: 	association_mac_key(Association, MacKey),
Chris@0: 	association_session_type(Association, SessionType),
Chris@0: 	signature_algorithm(SessionType, SHA),
Chris@0: 	hmac_sha(MacKey, TokenContents, Signature, [algorithm(SHA)]),
Chris@0: 	debug(openid(crypt), 'Signed:~n~s~nSignature: ~w', [TokenContents, Signature]).
Chris@0: 
Chris@0: signature_algorithm('DH-SHA1', sha1).
Chris@0: signature_algorithm('DH-SHA256', sha256).
Chris@0: 
Chris@0: 
Chris@0: 		 /*******************************
Chris@0: 		 *	       IMAGES		*
Chris@0: 		 *******************************/
Chris@0: 
Chris@0: %%	openid_file(+Request)
Chris@0: %
Chris@0: %	Serve fiels we use as logos, style-sheets, etc.
Chris@0: 
Chris@0: openid_file(Request) :-
Chris@0: 	http_parameters(Request,
Chris@0: 			[ name(Name, [])
Chris@0: 			]),
Chris@0: 	image_file(Name, File),
Chris@0: 	http_reply_file(File, [], Request).
Chris@0: 
Chris@0: 
Chris@0: image_file(openid_logo,	     library('http/openid-logo-square.png')).
Chris@0: image_file(openid_logo_tiny, library('http/openid-logo-tiny.png')).
Chris@0: image_file(openid_css,	     library('http/openid.css')).
Chris@0: 
Chris@0: 
Chris@0: 		 /*******************************
Chris@0: 		 *	      ASSOCIATE		*
Chris@0: 		 *******************************/
Chris@0: 
Chris@0: :- dynamic
Chris@0: 	association/3.			% URL, Handle, Data
Chris@0: 
Chris@0: :- record
Chris@0: 	association(session_type='DH-SHA1',
Chris@0: 		    expires_at,		% time-stamp
Chris@0: 		    mac_key).		% code-list
Chris@0: 
Chris@0: %%	openid_associate(+URL, -Handle, -Assoc) is det.
Chris@0: %%	openid_associate(?URL, +Handle, -Assoc) is semidet.
Chris@0: %
Chris@0: %	Associate with an open-id server.  We   first  check for a still
Chris@0: %	valid old association. If there is  none   or  it is expired, we
Chris@0: %	esstablish one and remember it.
Chris@0: %	
Chris@0: %	@tbd	Should we store known associations permanently?  Where?
Chris@0: 
Chris@0: openid_associate(URL, Handle, Assoc) :-
Chris@0: 	association(URL, Handle, Assoc),
Chris@0: 	association_expires_at(Assoc, Expires),
Chris@0: 	get_time(Now),
Chris@0: 	(   Now < Expires
Chris@0: 	->  debug(openid(associate), '~w: Reusing association', [URL])
Chris@0: 	;   retractall(association(URL, Handle, _)),
Chris@0: 	    fail
Chris@0: 	).
Chris@0: openid_associate(URL, Handle, Assoc) :-
Chris@0: 	ground(URL),
Chris@0: 	associate_data(Data, P, _G, X),
Chris@0: 	http_post(URL, form(Data), Reply, [to(codes)]),
Chris@0: 	debug(openid(associate), 'Reply: ~n~s', [Reply]),
Chris@0: 	key_values_data(Pairs, Reply),
Chris@0: 	shared_secret(Pairs, P, X, MacKey),
Chris@0: 	expires_at(Pairs, ExpiresAt),
Chris@0: 	memberchk(assoc_handle-Handle, Pairs),
Chris@0: 	memberchk(session_type-Type, Pairs),
Chris@0: 	make_association([ session_type(Type),
Chris@0: 			   expires_at(ExpiresAt),
Chris@0: 			   mac_key(MacKey)
Chris@0: 			 ], Assoc),
Chris@0: 	assert(association(URL, Handle, Assoc)).
Chris@0: 
Chris@0: 
Chris@0: %%	shared_secret(+Pairs, +P, +X, -Secret:list(codes))
Chris@0: %
Chris@0: %	Find the shared secret from the peer's reply and our data. First
Chris@0: %	clause deals with the (deprecated) non-encoded version.
Chris@0: 
Chris@0: shared_secret(Pairs, _, _, Secret) :-
Chris@0: 	memberchk(mac_key-Base64, Pairs), !,
Chris@0: 	atom_codes(Base64, Base64Codes),
Chris@0: 	phrase(base64(Base64Codes), Secret).
Chris@0: shared_secret(Pairs, P, X, Secret) :-
Chris@0: 	memberchk(dh_server_public-Base64Public, Pairs),
Chris@0: 	memberchk(enc_mac_key-Base64EncMacKey, Pairs),
Chris@0: 	base64_btwoc(ServerPublic, Base64Public),
Chris@0: 	DiffieHellman is powm(ServerPublic, X, P),
Chris@0: 	atom_codes(Base64EncMacKey, Base64EncMacKeyCodes),
Chris@0: 	phrase(base64(EncMacKey), Base64EncMacKeyCodes),
Chris@0: 	btwoc(DiffieHellman, DiffieHellmanBytes),
Chris@0: 	sha_hash(DiffieHellmanBytes, DHHash, [algorithm(sha1)]),
Chris@0: 	xor_codes(DHHash, EncMacKey, Secret).
Chris@0: 
Chris@0: 
Chris@0: %%	expires_at(+Pairs, -Time) is det.
Chris@0: %
Chris@0: %	Unify Time with  a  time-stamp   stating  when  the  association
Chris@0: %	exires.
Chris@0: 
Chris@0: expires_at(Pairs, Time) :-
Chris@0: 	memberchk(expires_in-ExpAtom, Pairs),
Chris@0: 	atom_number(ExpAtom, Seconds),
Chris@0: 	get_time(Now),
Chris@0: 	Time is integer(Now)+Seconds.
Chris@0: 
Chris@0: 
Chris@0: %%	associate_data(-Data, -X) is det.
Chris@0: %
Chris@0: %	Generate the data to initiate an association using Diffie-Hellman
Chris@0: %	shared secret key negotiation.
Chris@0: 
Chris@0: associate_data(Data, P, G, X) :-
Chris@0: 	openid_dh_p(P),
Chris@0: 	openid_dh_g(G),
Chris@0: 	dh_x(P, X),
Chris@0: 	CP is powm(G, X, P),
Chris@0: 	base64_btwoc(P, P64),
Chris@0: 	base64_btwoc(G, G64),
Chris@0: 	base64_btwoc(CP, CP64),
Chris@0: 	Data = [ 'openid.mode'		     = associate,
Chris@0: 		 'openid.assoc_type'	     = 'HMAC-SHA1',
Chris@0: 		 'openid.session_type'	     = 'DH-SHA1',
Chris@0: 		 'openid.dh_modulus'	     = P64,
Chris@0: 		 'openid.dh_gen'	     = G64,
Chris@0: 		 'openid.dh_consumer_public' = CP64
Chris@0: 	       ].
Chris@0: 
Chris@0: 
Chris@0: 		 /*******************************
Chris@0: 		 *	      RANDOM		*
Chris@0: 		 *******************************/
Chris@0: 
Chris@0: %%	random_bytes(+N, -Bytes) is det.
Chris@0: %
Chris@0: %	Bytes is a list of N random bytes (integers 0..255).
Chris@0: 
Chris@0: random_bytes(N, [H|T]) :-
Chris@0: 	N > 0, !,
Chris@0: 	H is random(256),
Chris@0: 	N2 is N - 1,
Chris@0: 	random_bytes(N2, T).
Chris@0: random_bytes(_, []).
Chris@0: 
Chris@0: 
Chris@0: %%	dh_x(+Max, -X)
Chris@0: %
Chris@0: %	Generate a random key X where 1<=X<P-1)
Chris@0: %	
Chris@0: %	@tbd	If we have /dev/urandom, use that.
Chris@0: 
Chris@0: dh_x(P, X) :-
Chris@0: 	X0 is random(65536),
Chris@0: 	Max is P - 1,
Chris@0: 	dh_x(Max, X0, X).
Chris@0: 
Chris@0: dh_x(Max, X0, X) :-
Chris@0: 	X1 is X0<<16+random(65536),
Chris@0: 	(   X1 >= Max
Chris@0: 	->  X = X0
Chris@0: 	;   dh_x(Max, X1, X)
Chris@0: 	).
Chris@0: 
Chris@0: 
Chris@0: 		 /*******************************
Chris@0: 		 *	     CONSTANTS		*
Chris@0: 		 *******************************/
Chris@0: 
Chris@0: openid_dh_p(155172898181473697471232257763715539915724801966915404479707795314057629378541917580651227423698188993727816152646631438561595825688188889951272158842675419950341258706556549803580104870537681476726513255747040765857479291291572334510643245094715007229621094194349783925984760375594985848253359305585439638443).
Chris@0: 
Chris@0: openid_dh_g(2).
Chris@0: 
Chris@0: 
Chris@0: 		 /*******************************
Chris@0: 		 *	       UTIL		*
Chris@0: 		 *******************************/
Chris@0: 
Chris@0: %%	key_values_data(+KeyValues:list(Key-Value), -Data:list(code)) is det.
Chris@0: %%	key_values_data(-KeyValues:list(Key-Value), +Data:list(code)) is det.
Chris@0: %
Chris@0: %	Encoding  and  decoding  of  key-value  pairs  for  OpenID  POST
Chris@0: %	messages  according  to   Appendix   C    of   the   OpenID  1.1
Chris@0: %	specification.
Chris@0: 
Chris@0: key_values_data(Pairs, Data) :-
Chris@0: 	nonvar(Data), !,
Chris@0: 	phrase(data_form(Pairs), Data).
Chris@0: key_values_data(Pairs, Data) :-
Chris@0: 	phrase(gen_data_form(Pairs), Data).
Chris@0: 	
Chris@0: data_form([Key-Value|Pairs]) -->
Chris@0: 	utf8_string(KeyCodes), ":", utf8_string(ValueCodes), "\n", !,
Chris@0: 	{ atom_codes(Key, KeyCodes),
Chris@0: 	  atom_codes(Value, ValueCodes)
Chris@0: 	},
Chris@0: 	data_form(Pairs).
Chris@0: data_form([]) -->
Chris@0: 	ws.
Chris@0: 
Chris@0: %%	utf8_string(-Codes)// is nondet.
Chris@0: %
Chris@0: %	Take a short UTF-8 code-list from input. Extend on backtracking.
Chris@0: 
Chris@0: utf8_string([]) -->
Chris@0: 	[].
Chris@0: utf8_string([H|T]) -->
Chris@0: 	utf8_codes([H]),
Chris@0: 	utf8_string(T).
Chris@0: 
Chris@0: ws -->
Chris@0: 	[C],
Chris@0: 	{ C =< 32 }, !,
Chris@0: 	ws.
Chris@0: ws -->
Chris@0: 	[].
Chris@0: 
Chris@0: 
Chris@0: gen_data_form([]) -->
Chris@0: 	[].
Chris@0: gen_data_form([Key-Value|T]) -->
Chris@0: 	field(Key), ":", field(Value), "\n",
Chris@0: 	gen_data_form(T).
Chris@0: 
Chris@0: field(Field) -->
Chris@0: 	{ to_codes(Field, Codes)
Chris@0: 	},
Chris@0: 	utf8_codes(Codes).
Chris@0: 
Chris@0: to_codes(Codes, Codes) :-
Chris@0: 	is_list(Codes), !.
Chris@0: to_codes(Atomic, Codes) :-
Chris@0: 	atom_codes(Atomic, Codes).
Chris@0: 
Chris@0: %%	base64_btwoc(+Int, -Base64:list(code)) is det.
Chris@0: %%	base64_btwoc(-Int, +Base64:list(code)) is det.
Chris@0: %%	base64_btwoc(-Int, +Base64:atom) is det.
Chris@0: 
Chris@0: base64_btwoc(Int, Base64) :-
Chris@0: 	integer(Int), !,
Chris@0: 	btwoc(Int, Bytes),
Chris@0: 	phrase(base64(Bytes), Base64).
Chris@0: base64_btwoc(Int, Base64) :-
Chris@0: 	atom(Base64), !,
Chris@0: 	atom_codes(Base64, Codes),
Chris@0: 	phrase(base64(Bytes), Codes),
Chris@0: 	btwoc(Int, Bytes).
Chris@0: base64_btwoc(Int, Base64) :-
Chris@0: 	phrase(base64(Bytes), Base64),
Chris@0: 	btwoc(Int, Bytes).
Chris@0: 
Chris@0: 
Chris@0: %%	btwoc(+Integer, -Bytes) is det.
Chris@0: %%	btwoc(-Integer, +Bytes) is det.
Chris@0: %
Chris@0: %	Translate between a big integer and and its representation in
Chris@0: %	bytes.  The first bit is always 0, as Integer is nonneg.
Chris@0: 
Chris@0: btwoc(Int, Bytes) :-
Chris@0: 	integer(Int), !,
Chris@0: 	int_to_bytes(Int, Bytes).
Chris@0: btwoc(Int, Bytes) :-
Chris@0: 	is_list(Bytes),
Chris@0: 	bytes_to_int(Bytes, Int).
Chris@0: 
Chris@0: int_to_bytes(Int, Bytes) :-
Chris@0: 	int_to_bytes(Int, [], Bytes).
Chris@0: 
Chris@0: int_to_bytes(Int, Bytes0, [Int|Bytes0]) :-
Chris@0: 	Int < 128, !.
Chris@0: int_to_bytes(Int, Bytes0, Bytes) :-
Chris@0: 	Last is Int /\ 0xff,
Chris@0: 	Int1 is Int >> 8,
Chris@0: 	int_to_bytes(Int1, [Last|Bytes0], Bytes).
Chris@0: 
Chris@0: 
Chris@0: bytes_to_int([B|T], Int) :-
Chris@0: 	bytes_to_int(T, B, Int).
Chris@0: 
Chris@0: bytes_to_int([], Int, Int).
Chris@0: bytes_to_int([B|T], Int0, Int) :-
Chris@0: 	Int1 is (Int0<<8)+B,
Chris@0: 	bytes_to_int(T, Int1, Int).
Chris@0: 
Chris@0: 
Chris@0: %%	xor_codes(+C1:list(int), +C2:list(int), -XOR:list(int)) is det.
Chris@0: %
Chris@0: %	Compute xor of two strings.
Chris@0: %	
Chris@0: %	@error	length_mismatch(L1, L2) if the two lists do not have equal
Chris@0: %		length.
Chris@0: 
Chris@0: xor_codes([], [], []).
Chris@0: xor_codes([H1|T1], [H2|T2], [H|T]) :-
Chris@0: 	H is H1 xor H2, !,
Chris@0: 	xor_codes(T1, T2, T).
Chris@0: xor_codes(L1, L2, _) :-
Chris@0: 	throw(error(length_mismatch(L1, L2), _)).
Chris@0: 
Chris@0: 
Chris@0: 		 /*******************************
Chris@0: 		 *	  HTTP ATTRIBUTES	*
Chris@0: 		 *******************************/
Chris@0: 
Chris@0: openid_attribute('openid.mode',
Chris@0: 		 [ oneof([ associate,
Chris@0: 			   checkid_setup,
Chris@0: 			   cancel,
Chris@0: 			   id_res
Chris@0: 			 ])
Chris@0: 		 ]).
Chris@0: openid_attribute('openid.assoc_type',
Chris@0: 		 [ oneof(['HMAC-SHA1'])
Chris@0: 		 ]).
Chris@0: openid_attribute('openid.session_type',
Chris@0: 		 [ oneof([ 'DH-SHA1',
Chris@0: 			   'DH-SHA256'
Chris@0: 			 ])
Chris@0: 		 ]).
Chris@0: openid_attribute('openid.dh_modulus',	      [length > 1]).
Chris@0: openid_attribute('openid.dh_gen', 	      [length > 1]).
Chris@0: openid_attribute('openid.dh_consumer_public', [length > 1]).
Chris@0: openid_attribute('openid.assoc_handle',	      [length > 1]).
Chris@0: openid_attribute('openid.return_to',	      [length > 1]).
Chris@0: openid_attribute('openid.trust_root',	      [length > 1]).
Chris@0: openid_attribute('openid.identity',	      [length > 1]).
Chris@0: openid_attribute('openid.password',	      [length > 1]).
Chris@0: openid_attribute('openid.grant',	      [oneof([yes,no])]).