kibi-swipl-linux-x64-gnu 1.0.0

package/lib/swipl/library/ext/http/http/http_openid.pl

@@ -0,0 +1,1561 @@
+/*  Part of SWI-Prolog
+
+    Author:        Jan Wielemaker
+    E-mail:        J.Wielemaker@vu.nl
+    WWW:           http://www.swi-prolog.org
+    Copyright (c)  2010-2015, University of Amsterdam,
+                              VU University Amsterdam
+    All rights reserved.
+
+    Redistribution and use in source and binary forms, with or without
+    modification, are permitted provided that the following conditions
+    are met:
+
+    1. Redistributions of source code must retain the above copyright
+       notice, this list of conditions and the following disclaimer.
+
+    2. Redistributions in binary form must reproduce the above copyright
+       notice, this list of conditions and the following disclaimer in
+       the documentation and/or other materials provided with the
+       distribution.
+
+    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
+    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+    POSSIBILITY OF SUCH DAMAGE.
+*/
+
+:- module(http_openid,
+          [ openid_login/1,             % +OpenID
+            openid_logout/1,            % +OpenID
+            openid_logged_in/1,         % -OpenID
+
+                                        % transparent login
+            openid_user/3,              % +Request, -User, +Options
+
+                                        % low-level primitives
+            openid_verify/2,            % +Options, +Request
+            openid_authenticate/4,      % +Request, -Server, -Identity, -ReturnTo
+            openid_associate/3,         % +OpenIDServer, -Handle, -Association
+            openid_associate/4,         % +OpenIDServer, -Handle, -Association,
+                                        % +Options
+            openid_server/2,            % +Options, +Request
+            openid_server/3,            % ?OpenIDLogin, ?OpenID, ?Server
+            openid_grant/1,             % +Request
+
+            openid_login_form//2,       % +ReturnTo, +Options, //
+
+            openid_current_url/2,       % +Request, -URL
+            openid_current_host/3       % +Request, -Host, -Port
+          ]).
+:- use_module(library(http/http_open)).
+:- use_module(library(http/html_write)).
+:- use_module(library(http/http_parameters)).
+:- use_module(library(http/http_dispatch)).
+:- use_module(library(http/http_session)).
+:- use_module(library(http/http_host)).
+:- use_module(library(http/http_path)).
+:- use_module(library(http/html_head)).
+:- use_module(library(http/http_server_files), []).
+:- use_module(library(http/yadis)).
+:- use_module(library(http/ax)).
+:- use_module(library(utf8)).
+:- use_module(library(error)).
+:- use_module(library(xpath)).
+:- use_module(library(sgml)).
+:- use_module(library(uri)).
+:- use_module(library(occurs)).
+:- use_module(library(base64)).
+:- use_module(library(debug)).
+:- use_module(library(record)).
+:- use_module(library(option)).
+:- use_module(library(sha)).
+:- use_module(library(lists)).
+:- use_module(library(settings)).
+
+:- predicate_options(openid_login_form/4, 2,
+                     [ action(atom),
+                       buttons(list),
+                       show_stay(boolean)
+                     ]).
+:- predicate_options(openid_server/2, 1,
+                     [ expires_in(any)
+                     ]).
+:- predicate_options(openid_user/3, 3,
+                     [ login_url(atom)
+                     ]).
+:- predicate_options(openid_verify/2, 1,
+                     [ return_to(atom),
+                       trust_root(atom),
+                       realm(atom),
+                       ax(any)
+                     ]).
+
+/** <module> OpenID consumer and server library
+
+This library implements the OpenID protocol (http://openid.net/). OpenID
+is a protocol to share identities on   the  network. The protocol itself
+uses simple basic  HTTP,  adding   reliability  using  digitally  signed
+messages.
+
+Steps, as seen from the _consumer_ (or _|relying partner|_).
+
+        1. Show login form, asking for =openid_identifier=
+        2. Get HTML page from =openid_identifier= and lookup
+           =|<link rel="openid.server" href="server">|=
+        3. Associate to _server_
+        4. Redirect browser (302) to server using mode =checkid_setup=,
+           asking to validate the given OpenID.
+        5. OpenID server redirects back, providing digitally signed
+           conformation of the claimed identity.
+        6. Validate signature and redirect to the target location.
+
+A *consumer* (an application that allows OpenID login) typically uses
+this library through openid_user/3. In addition, it must implement the
+hook http_openid:openid_hook(trusted(OpenId, Server)) to define accepted
+OpenID servers. Typically, this hook is used to provide a white-list of
+acceptable servers. Note that accepting any OpenID server is possible,
+but anyone on the internet can setup a dummy OpenID server that simply
+grants and signs every request. Here is an example:
+
+    ==
+    :- multifile http_openid:openid_hook/1.
+
+    http_openid:openid_hook(trusted(_, OpenIdServer)) :-
+        (   trusted_server(OpenIdServer)
+        ->  true
+        ;   throw(http_reply(moved_temporary('/openid/trustedservers')))
+        ).
+
+    trusted_server('http://www.myopenid.com/server').
+    ==
+
+By default, information who is logged on  is maintained with the session
+using http_session_assert/1 with the term   openid(Identity).  The hooks
+login/logout/logged_in can be used to provide alternative administration
+of logged-in users (e.g., based on client-IP, using cookies, etc.).
+
+To create a *server*,  you  must  do   four  things:  bind  the handlers
+openid_server/2  and  openid_grant/1  to  HTTP    locations,  provide  a
+user-page for registered users and   define  the grant(Request, Options)
+hook to verify  your  users.  An  example   server  is  provided  in  in
+<plbase>/doc/packages/examples/demo_openid.pl
+*/
+
+                 /*******************************
+                 *        CONFIGURATION         *
+                 *******************************/
+
+http:location(openid, root(openid), [priority(-100)]).
+
+%!  openid_hook(+Action)
+%
+%   Call hook on the OpenID management library.  Defined hooks are:
+%
+%     * login(+OpenID)
+%     Consider OpenID logged in.
+%
+%     * logout(+OpenID)
+%     Logout OpenID
+%
+%     * logged_in(?OpenID)
+%     True if OpenID is logged in
+%
+%     * grant(+Request, +Options)
+%     Server: Reply positive on OpenID
+%
+%     * trusted(+OpenID, +Server)
+%     True if Server is a trusted OpenID server
+%
+%     * ax(Values)
+%     Called if the server provided AX attributes
+%
+%     * x_parameter(+Server, -Name, -Value)
+%     Called to find additional HTTP parameters to send with the
+%     OpenID verify request.
+
+:- multifile
+    openid_hook/1.                  % +Action
+
+                 /*******************************
+                 *       DIRECT LOGIN/OUT       *
+                 *******************************/
+
+%!  openid_login(+OpenID) is det.
+%
+%   Associate the current  HTTP  session   with  OpenID.  If another
+%   OpenID is already associated, this association is first removed.
+
+openid_login(OpenID) :-
+    openid_hook(login(OpenID)),
+    !,
+    handle_stay_signed_in(OpenID).
+openid_login(OpenID) :-
+    openid_logout(_),
+    http_session_assert(openid(OpenID)),
+    handle_stay_signed_in(OpenID).
+
+%!  openid_logout(+OpenID) is det.
+%
+%   Remove the association of the current session with any OpenID
+
+openid_logout(OpenID) :-
+    openid_hook(logout(OpenID)),
+    !.
+openid_logout(OpenID) :-
+    http_session_retractall(openid(OpenID)).
+
+%!  openid_logged_in(-OpenID) is semidet.
+%
+%   True if session is associated with OpenID.
+
+openid_logged_in(OpenID) :-
+    openid_hook(logged_in(OpenID)),
+    !.
+openid_logged_in(OpenID) :-
+    http_in_session(_SessionId),            % test in session
+    http_session_data(openid(OpenID)).
+
+
+                 /*******************************
+                 *            TOPLEVEL          *
+                 *******************************/
+
+%!  openid_user(+Request:http_request, -OpenID:url, +Options) is det.
+%
+%   True if OpenID is a validated OpenID associated with the current
+%   session. The scenario for which this predicate is designed is to
+%   allow  an  HTTP  handler  that  requires    a   valid  login  to
+%   use the transparent code below.
+%
+%     ==
+%     handler(Request) :-
+%           openid_user(Request, OpenID, []),
+%           ...
+%     ==
+%
+%   If the user is not yet logged on a sequence of redirects will
+%   follow:
+%
+%     1. Show a page for login (default: page /openid/login),
+%        predicate reply_openid_login/1)
+%     2. By default, the OpenID login page is a form that is
+%        submitted to the =verify=, which calls openid_verify/2.
+%     3. openid_verify/2 does the following:
+%        - Find the OpenID claimed identity and server
+%        - Associate to the OpenID server
+%        - redirects to the OpenID server for validation
+%     4. The OpenID server will redirect here with the authentication
+%        information.  This is handled by openid_authenticate/4.
+%
+%   Options:
+%
+%     * login_url(Login)
+%       (Local) URL of page to enter OpenID information. Default
+%       is the handler for openid_login_page/1
+%
+%   @see openid_authenticate/4 produces errors if login is invalid
+%   or cancelled.
+
+:- http_handler(openid(login),        openid_login_page,   [priority(-10)]).
+:- http_handler(openid(verify),       openid_verify([]),   []).
+:- http_handler(openid(authenticate), openid_authenticate, []).
+:- http_handler(openid(xrds),         openid_xrds,         []).
+
+openid_user(_Request, OpenID, _Options) :-
+    openid_logged_in(OpenID),
+    !.
+openid_user(Request, _OpenID, Options) :-
+    http_link_to_id(openid_login_page, [], DefLoginPage),
+    option(login_url(LoginPage), Options, DefLoginPage),
+    openid_current_url(Request, Here),
+    redirect_browser(LoginPage,
+                     [ 'openid.return_to' = Here
+                     ]).
+
+%!  openid_xrds(Request)
+%
+%   Reply to a request  for   "Discovering  OpenID Relying Parties".
+%   This may happen as part of  the provider verification procedure.
+%   The  provider  will   do   a    Yadis   discovery   request   on
+%   =openid.return=  or  =openid.realm=.  This  is    picked  up  by
+%   openid_user/3, pointing the provider to   openid(xrds).  Now, we
+%   reply with the locations marked =openid=  and the locations that
+%   have actually been doing OpenID validations.
+
+openid_xrds(Request) :-
+    http_link_to_id(openid_authenticate, [], Autheticate),
+    public_url(Request, Autheticate, Public),
+    format('Content-type: text/xml\n\n'),
+    format('<?xml version="1.0" encoding="UTF-8"?>\n'),
+    format('<xrds:XRDS\n'),
+    format('    xmlns:xrds="xri://$xrds"\n'),
+    format('    xmlns="xri://$xrd*($v*2.0)">\n'),
+    format('  <XRD>\n'),
+    format('    <Service>\n'),
+    format('      <Type>http://specs.openid.net/auth/2.0/return_to</Type>\n'),
+    format('      <URI>~w</URI>\n', [Public]),
+    format('    </Service>\n'),
+    format('  </XRD>\n'),
+    format('</xrds:XRDS>\n').
+
+
+%!  openid_login_page(+Request) is det.
+%
+%   Present a login-form for OpenID. There  are two ways to redefine
+%   this  default  login  page.  One  is    to  provide  the  option
+%   =login_url= to openid_user/3 and the other   is  to define a new
+%   handler for =|/openid/login|= using http_handler/3.
+
+openid_login_page(Request) :-
+    http_open_session(_, []),
+    http_parameters(Request,
+                    [ 'openid.return_to'(Target, [])
+                    ]),
+    reply_html_page([ title('OpenID login')
+                    ],
+                    [ \openid_login_form(Target, [])
+                    ]).
+
+%!  openid_login_form(+ReturnTo, +Options)// is det.
+%
+%   Create the OpenID  form.  This  exported   as  a  separate  DCG,
+%   allowing applications to redefine /openid/login   and reuse this
+%   part of the page.  Options processed:
+%
+%     - action(Action)
+%     URL of action to call.  Default is the handler calling
+%     openid_verify/1.
+%     - buttons(+Buttons)
+%     Buttons is a list of =img= structures where the =href=
+%     points to an OpenID 2.0 endpoint.  These buttons are
+%     displayed below the OpenID URL field.  Clicking the
+%     button sets the URL field and submits the form.  Requires
+%     Javascript support.
+%
+%     If the =href= is _relative_, clicking it opens the given
+%     location after adding 'openid.return_to' and `stay'.
+%     - show_stay(+Boolean)
+%     If =true=, show a checkbox that allows the user to stay
+%     logged on.
+
+openid_login_form(ReturnTo, Options) -->
+    { http_link_to_id(openid_verify, [], VerifyLocation),
+      option(action(Action), Options, VerifyLocation),
+      http_session_retractall(openid(_)),
+      http_session_retractall(openid_login(_,_,_,_)),
+      http_session_retractall(ax(_))
+    },
+    html(div([ class('openid-login')
+             ],
+             [ \openid_title,
+               form([ name(login),
+                      id(login),
+                      action(Action),
+                      method('GET')
+                    ],
+                    [ \hidden('openid.return_to', ReturnTo),
+                      div([ input([ class('openid-input'),
+                                    name(openid_url),
+                                    id(openid_url),
+                                    size(30),
+                                    placeholder('Your OpenID URL')
+                                  ]),
+                            input([ type(submit),
+                                    value('Verify!')
+                                  ])
+                          ]),
+                      \buttons(Options),
+                      \stay_logged_on(Options)
+                    ])
+             ])).
+
+stay_logged_on(Options) -->
+    { option(show_stay(true), Options) },
+    !,
+    html(div(class('openid-stay'),
+             [ input([ type(checkbox), id(stay), name(stay), value(yes)]),
+               'Stay signed in'
+             ])).
+stay_logged_on(_) --> [].
+
+buttons(Options) -->
+    { option(buttons(Buttons), Options),
+      Buttons \== []
+    },
+    html(div(class('openid-buttons'),
+             [ 'Sign in with '
+             | \prelogin_buttons(Buttons)
+             ])).
+buttons(_) --> [].
+
+prelogin_buttons([]) --> [].
+prelogin_buttons([H|T]) --> prelogin_button(H), prelogin_buttons(T).
+
+%!  prelogin_button(+Image)// is det.
+%
+%   Handle OpenID 2.0 and other pre-login  buttons. If the image has
+%   a =href= attribute that is absolute, it   is  taken as an OpenID
+%   2.0 endpoint. Otherwise it is taken  as   a  link on the current
+%   server. This allows us to present  non-OpenId logons in the same
+%   screen. The dedicated  handler  is  passed  the  HTTP parameters
+%   =openid.return_to= and =stay=.
+
+prelogin_button(img(Attrs)) -->
+    { select_option(href(HREF), Attrs, RestAttrs),
+      uri_is_global(HREF), !
+    },
+    html(img([ onClick('javascript:{$("#openid_url").val("'+HREF+'");'+
+                       '$("form#login").submit();}'
+                      )
+                 | RestAttrs
+             ])).
+prelogin_button(img(Attrs)) -->
+    { select_option(href(HREF), Attrs, RestAttrs)
+    },
+    html(img([ onClick('window.location = "'+HREF+
+                       '?openid.return_to="'+
+                       '+encodeURIComponent($("#return_to").val())'+
+                       '+"&stay="'+
+                       '+$("#stay").val()')
+             | RestAttrs
+             ])).
+
+
+                 /*******************************
+                 *          HTTP REPLIES        *
+                 *******************************/
+
+%!  openid_verify(+Options, +Request)
+%
+%   Handle the initial login  form  presented   to  the  user by the
+%   relying party (consumer). This predicate   discovers  the OpenID
+%   server, associates itself with  this   server  and redirects the
+%   user's  browser  to  the  OpenID  server,  providing  the  extra
+%   openid.X name-value pairs. Options is,  against the conventions,
+%   placed in front of the Request   to allow for smooth cooperation
+%   with http_dispatch.pl.  Options processes:
+%
+%     * return_to(+URL)
+%     Specifies where the OpenID provider should return to.
+%     Normally, that is the current location.
+%     * trust_root(+URL)
+%     Specifies the =openid.trust_root= attribute.  Defaults to
+%     the root of the current server (i.e., =|http://host[.port]/|=).
+%     * realm(+URL)
+%     Specifies the =openid.realm= attribute.  Default is the
+%     =trust_root=.
+%     * ax(+Spec)
+%     Request the exchange of additional attributes from the
+%     identity provider.  See http_ax_attributes/2 for details.
+%
+%   The OpenId server will redirect to the =openid.return_to= URL.
+%
+%   @throws http_reply(moved_temporary(Redirect))
+
+openid_verify(Options, Request) :-
+    http_parameters(Request,
+                    [ openid_url(URL, [length>1]),
+                      'openid.return_to'(ReturnTo0, [optional(true)]),
+                      stay(Stay, [optional(true), default(no)])
+                    ]),
+    (   option(return_to(ReturnTo1), Options)       % Option
+    ->  openid_current_url(Request, CurrentLocation),
+        global_url(ReturnTo1, CurrentLocation, ReturnTo)
+    ;   nonvar(ReturnTo0)
+    ->  ReturnTo = ReturnTo0                        % Form-data
+    ;   openid_current_url(Request, CurrentLocation),
+        ReturnTo = CurrentLocation                  % Current location
+    ),
+    public_url(Request, /, CurrentRoot),
+    option(trust_root(TrustRoot), Options, CurrentRoot),
+    option(realm(Realm), Options, TrustRoot),
+    openid_resolve(URL, OpenIDLogin, OpenID, Server, ServerOptions),
+    trusted(OpenID, Server),
+    openid_associate(Server, Handle, _Assoc),
+    assert_openid(OpenIDLogin, OpenID, Server, ReturnTo),
+    stay(Stay),
+    option(ns(NS), Options, 'http://specs.openid.net/auth/2.0'),
+    (   realm_attribute(NS, RealmAttribute)
+    ->  true
+    ;   domain_error('openid.ns', NS)
+    ),
+    findall(P=V, openid_hook(x_parameter(Server, P, V)), XAttrs, AXAttrs),
+    debug(openid(verify), 'XAttrs: ~p', [XAttrs]),
+    ax_options(ServerOptions, Options, AXAttrs),
+    http_link_to_id(openid_authenticate, [], AuthenticateLoc),
+    public_url(Request, AuthenticateLoc, Authenticate),
+    redirect_browser(Server, [ 'openid.ns'           = NS,
+                               'openid.mode'         = checkid_setup,
+                               'openid.identity'     = OpenID,
+                               'openid.claimed_id'   = OpenID,
+                               'openid.assoc_handle' = Handle,
+                               'openid.return_to'    = Authenticate,
+                               RealmAttribute        = Realm
+                             | XAttrs
+                             ]).
+
+realm_attribute('http://specs.openid.net/auth/2.0', 'openid.realm').
+realm_attribute('http://openid.net/signon/1.1',     'openid.trust_root').
+
+
+%!  stay(+Response)
+%
+%   Called if the user  ask  to  stay   signed  in.  This  is called
+%   _before_ control is handed to the   OpenID server. It leaves the
+%   data openid_stay_signed_in(true) in the current session.
+
+stay(yes) :-
+    !,
+    http_session_assert(openid_stay_signed_in(true)).
+stay(_).
+
+%!  handle_stay_signed_in(+OpenID)
+%
+%   Handle stay_signed_in option after the user has logged on
+
+handle_stay_signed_in(OpenID) :-
+    http_session_retract(openid_stay_signed_in(true)),
+    !,
+    http_set_session(timeout(0)),
+    ignore(openid_hook(stay_signed_in(OpenID))).
+handle_stay_signed_in(_).
+
+%!  assert_openid(+OpenIDLogin, +OpenID, +Server, +Target) is det.
+%
+%   Associate the OpenID  as  typed  by   the  user,  the  OpenID as
+%   validated by the Server with the current HTTP session.
+%
+%   @param OpenIDLogin Canonized OpenID typed by user
+%   @param OpenID OpenID verified by Server.
+
+assert_openid(OpenIDLogin, OpenID, Server, Target) :-
+    openid_identifier_select_url(OpenIDLogin),
+    openid_identifier_select_url(OpenID),
+    !,
+    assert_openid_in_session(openid_login(Identity, Identity, Server, Target)).
+assert_openid(OpenIDLogin, OpenID, Server, Target) :-
+    assert_openid_in_session(openid_login(OpenIDLogin, OpenID, Server, Target)).
+
+assert_openid_in_session(Term) :-
+    (   http_in_session(_0Session)
+    ->  debug(openid(verify), 'Assert ~p in ~p', [Term, _0Session])
+    ;   debug(openid(verify), 'No session!', [])
+    ),
+    http_session_assert(Term).
+
+%!  openid_server(?OpenIDLogin, ?OpenID, ?Server) is nondet.
+%
+%   True if OpenIDLogin is the typed id for OpenID verified by
+%   Server.
+%
+%   @param OpenIDLogin ID as typed by user (canonized)
+%   @param OpenID ID as verified by server
+%   @param Server URL of the OpenID server
+
+openid_server(OpenIDLogin, OpenID, Server) :-
+    openid_server(OpenIDLogin, OpenID, Server, _Target).
+
+openid_server(OpenIDLogin, OpenID, Server, Target) :-
+    http_in_session(_0Session),
+    (   http_session_data(openid_login(OpenIDLogin, OpenID, Server, Target))
+    ->  true
+    ;   http_session_data(openid_login(_0OpenIDLogin1, _0OpenID1,
+                                       _0Server1, _0Target1)),
+        debug(openid(verify), '~p \\== ~p',
+              [ openid_login(OpenIDLogin, OpenID, Server, Target),
+                openid_login(_0OpenIDLogin1, _0OpenID1, _0Server1, _0Target1)
+              ]),
+        fail
+    ;   debug(openid(verify), 'No openid_login/4 term in session ~p',
+              [_0Session]),
+        fail
+    ).
+
+
+%!  public_url(+Request, +Path, -URL) is det.
+%
+%   True when URL is a publicly usable  URL that leads to Path on
+%   the current server.
+
+public_url(Request, Path, URL) :-
+    openid_current_host(Request, Host, Port),
+    setting(http:public_scheme, Scheme),
+    set_port(Scheme, Port, AuthC),
+    uri_authority_data(host, AuthC, Host),
+    uri_authority_components(Auth, AuthC),
+    uri_data(scheme, Components, Scheme),
+    uri_data(authority, Components, Auth),
+    uri_data(path, Components, Path),
+    uri_components(URL, Components).
+
+set_port(Scheme, Port, _) :-
+    scheme_port(Scheme, Port),
+    !.
+set_port(_, Port, AuthC) :-
+    uri_authority_data(port, AuthC, Port).
+
+scheme_port(http, 80).
+scheme_port(https, 443).
+
+
+%!  openid_current_url(+Request, -URL) is det.
+%
+%   Find the public URL for Request that   we  can make available to our
+%   identity provider. This must be an  absolute   URL  where  we can be
+%   contacted.   Before   trying   a     configured    version   through
+%   http_public_url/2, we try to see whether the login message contains a
+%   referrer parameter or whether the browser provided one.
+
+openid_current_url(Request, URL) :-
+    option(request_uri(URI), Request),
+    uri_components(URI, Components),
+    uri_data(path, Components, Path),
+    (   uri_data(search, Components, QueryString),
+        nonvar(QueryString),
+        uri_query_components(QueryString, Query),
+        memberchk(referer=Base, Query)
+    ->  true
+    ;   option(referer(Base), Request)
+    ), !,
+    uri_normalized(Path, Base, URL).
+openid_current_url(Request, URL) :-
+    http_public_url(Request, URL).
+
+%!  openid_current_host(Request, Host, Port)
+%
+%   Find current location of the server.
+%
+%   @deprecated     New code should use http_current_host/4 with the
+%                   option global(true).
+
+openid_current_host(Request, Host, Port) :-
+    http_current_host(Request, Host, Port,
+                      [ global(true)
+                      ]).
+
+
+%!  redirect_browser(+URL, +FormExtra)
+%
+%   Generate a 302 temporary redirect to  URL, adding the extra form
+%   information from FormExtra. The specs says   we  must retain the
+%   search specification already attached to the URL.
+
+redirect_browser(URL, FormExtra) :-
+    uri_components(URL, C0),
+    uri_data(search, C0, Search0),
+    (   var(Search0)
+    ->  uri_query_components(Search, FormExtra)
+    ;   uri_query_components(Search0, Form0),
+        append(FormExtra, Form0, Form),
+        uri_query_components(Search, Form)
+    ),
+    uri_data(search, C0, Search, C),
+    uri_components(Redirect, C),
+    throw(http_reply(moved_temporary(Redirect))).
+
+
+                 /*******************************
+                 *             RESOLVE          *
+                 *******************************/
+
+%!  openid_resolve(+URL, -OpenIDOrig, -OpenID, -Server, -ServerOptions)
+%
+%   True if OpenID is the claimed  OpenID   that  belongs to URL and
+%   Server is the URL of the  OpenID   server  that  can be asked to
+%   verify this claim.
+%
+%   @param  URL The OpenID typed by the user
+%   @param  OpenIDOrig Canonized OpenID typed by user
+%   @param  OpenID Possibly delegated OpenID
+%   @param  Server OpenID server that must validate OpenID
+%   @param  ServerOptions provides additional XRDS information about
+%           the server.  Currently supports xrds_types(Types).
+%   @tbd    Implement complete URL canonization as defined by the
+%           OpenID 2.0 proposal.
+
+openid_resolve(URL, OpenID, OpenID, Server, [xrds_types(Types)]) :-
+    xrds_dom(URL, DOM),
+    xpath(DOM, //(_:'Service'), Service),
+    findall(Type, xpath(Service, _:'Type'(text), Type), Types),
+    memberchk('http://specs.openid.net/auth/2.0/server', Types),
+    xpath(Service, _:'URI'(text), Server),
+    !,
+    debug(openid(yadis), 'Yadis: server: ~q, types: ~q', [Server, Types]),
+    (   xpath(Service, _:'LocalID'(text), OpenID)
+    ->  true
+    ;   openid_identifier_select_url(OpenID)
+    ).
+openid_resolve(URL, OpenID0, OpenID, Server, []) :-
+    debug(openid(resolve), 'Opening ~w ...', [URL]),
+    dtd(html, DTD),
+    setup_call_cleanup(
+        http_open(URL, Stream,
+                  [ final_url(OpenID0),
+                    cert_verify_hook(ssl_verify)
+                  ]),
+        load_structure(Stream, Term,
+                       [ dtd(DTD),
+                         dialect(sgml),
+                         shorttag(false),
+                         syntax_errors(quiet)
+                       ]),
+        close(Stream)),
+    debug(openid(resolve), 'Scanning HTML document ...', []),
+    contains_term(element(head, _, Head), Term),
+    (   link(Head, 'openid.server', Server)
+    ->  debug(openid(resolve), 'OpenID Server=~q', [Server])
+    ;   debug(openid(resolve), 'No server in ~q', [Head]),
+        fail
+    ),
+    (   link(Head, 'openid.delegate', OpenID)
+    ->  debug(openid(resolve), 'OpenID = ~q (delegated)', [OpenID])
+    ;   OpenID = OpenID0,
+        debug(openid(resolve), 'OpenID = ~q', [OpenID])
+    ).
+
+openid_identifier_select_url(
+    'http://specs.openid.net/auth/2.0/identifier_select').
+
+:- public ssl_verify/5.
+
+%!  ssl_verify(+SSL, +ProblemCert, +AllCerts, +FirstCert, +Error)
+%
+%   Accept all certificates. We do not care  too much. Only the user
+%   cares s/he is not entering her  credentials with a spoofed side.
+%   As we redirect, the browser will take care of this.
+
+ssl_verify(_SSL,
+           _ProblemCertificate, _AllCertificates, _FirstCertificate,
+           _Error).
+
+
+link(DOM, Type, Target) :-
+    sub_term(element(link, Attrs, []), DOM),
+    memberchk(rel=Type, Attrs),
+    memberchk(href=Target, Attrs).
+
+
+                 /*******************************
+                 *         AUTHENTICATE         *
+                 *******************************/
+
+%!  openid_authenticate(+Request)
+%
+%   HTTP handler when redirected back from the OpenID provider.
+
+openid_authenticate(Request) :-
+    memberchk(accept(Accept), Request),
+    Accept = [media(application/'xrds+xml',_,_,_)],
+    !,
+    http_link_to_id(openid_xrds, [], XRDSLocation),
+    http_absolute_uri(XRDSLocation, XRDSServer),
+    debug(openid(yadis), 'Sending XRDS server: ~q', [XRDSServer]),
+    format('X-XRDS-Location: ~w\n', [XRDSServer]),
+    format('Content-type: text/plain\n\n').
+openid_authenticate(Request) :-
+    openid_authenticate(Request, _OpenIdServer, OpenID, _ReturnTo),
+    openid_server(User, OpenID, _, Target),
+    openid_login(User),
+    redirect_browser(Target, []).
+
+
+%!  openid_authenticate(+Request, -Server:url, -OpenID:url,
+%!                      -ReturnTo:url) is semidet.
+%
+%   Succeeds if Request comes from the   OpenID  server and confirms
+%   that User is a verified OpenID   user. ReturnTo provides the URL
+%   to return to.
+%
+%   After openid_verify/2 has redirected the   browser to the OpenID
+%   server, and the OpenID server did   its  magic, it redirects the
+%   browser back to this address.  The   work  is fairly trivial. If
+%   =mode= is =cancel=, the OpenId server   denied. If =id_res=, the
+%   OpenId server replied positive, but  we   must  verify  what the
+%   server told us by checking the HMAC-SHA signature.
+%
+%   This call fails silently if their is no =|openid.mode|= field in
+%   the request.
+%
+%   @throws openid(cancel)
+%           if request was cancelled by the OpenId server
+%   @throws openid(signature_mismatch)
+%           if the HMAC signature check failed
+
+openid_authenticate(Request, OpenIdServer, Identity, ReturnTo) :-
+    memberchk(method(get), Request),
+    http_parameters(Request,
+                    [ 'openid.mode'(Mode, [optional(true)])
+                    ]),
+    (   var(Mode)
+    ->  fail
+    ;   Mode == cancel
+    ->  throw(openid(cancel))
+    ;   Mode == id_res
+    ->  debug(openid(authenticate), 'Mode=id_res, validating response', []),
+        http_parameters(Request,
+                        [ 'openid.identity'(Identity, []),
+                          'openid.assoc_handle'(Handle, []),
+                          'openid.return_to'(ReturnTo, []),
+                          'openid.signed'(AtomFields, []),
+                          'openid.sig'(Base64Signature, []),
+                          'openid.invalidate_handle'(Invalidate,
+                                                     [optional(true)])
+                        ],
+                        [ form_data(Form)
+                        ]),
+        atomic_list_concat(SignedFields, ',', AtomFields),
+        check_obligatory_fields(SignedFields),
+        signed_pairs(SignedFields,
+                     [ mode-Mode,
+                       identity-Identity,
+                       assoc_handle-Handle,
+                       return_to-ReturnTo,
+                       invalidate_handle-Invalidate
+                     ],
+                     Form,
+                     SignedPairs),
+        (   openid_associate(OpenIdServer, Handle, Assoc)
+        ->  signature(SignedPairs, Assoc, Sig),
+            atom_codes(Base64Signature, Base64SigCodes),
+            phrase(base64(Signature), Base64SigCodes),
+            (   Sig == Signature
+            ->  true
+            ;   throw(openid(signature_mismatch))
+            )
+        ;   check_authentication(Request, Form)
+        ),
+        ax_store(Form)
+    ).
+
+%!  signed_pairs(+FieldNames, +Pairs:list(Field-Value),
+%!               +Form, -SignedPairs) is det.
+%
+%   Extract the signed field in the order they appear in FieldNames.
+
+signed_pairs([], _, _, []).
+signed_pairs([Field|T0], Pairs, Form, [Field-Value|T]) :-
+    memberchk(Field-Value, Pairs),
+    !,
+    signed_pairs(T0, Pairs, Form, T).
+signed_pairs([Field|T0], Pairs, Form, [Field-Value|T]) :-
+    atom_concat('openid.', Field, OpenIdField),
+    memberchk(OpenIdField=Value, Form),
+    !,
+    signed_pairs(T0, Pairs, Form, T).
+signed_pairs([Field|T0], Pairs, Form, T) :-
+    format(user_error, 'Form = ~p~n', [Form]),
+    throw(error(existence_error(field, Field),
+                context(_, 'OpenID Signed field is not present'))),
+    signed_pairs(T0, Pairs, Form, T).
+
+
+%!  check_obligatory_fields(+SignedFields:list) is det.
+%
+%   Verify fields from obligatory_field/1 are   in  the signed field
+%   list.
+%
+%   @error  existence_error(field, Field)
+
+check_obligatory_fields(Fields) :-
+    (   obligatory_field(Field),
+        (   memberchk(Field, Fields)
+        ->  true
+        ;   throw(error(existence_error(field, Field),
+                        context(_, 'OpenID field is not in signed fields')))
+        ),
+        fail
+    ;   true
+    ).
+
+obligatory_field(identity).
+
+
+%!  check_authentication(+Request, +Form) is semidet.
+%
+%   Implement the stateless verification method.   This seems needed
+%   for stackexchange.com, which provides the   =res_id=  with a new
+%   association handle.
+
+check_authentication(_Request, Form) :-
+    openid_server(_OpenIDLogin, _OpenID, Server),
+    debug(openid(check_authentication),
+          'Using stateless verification with ~q form~n~q', [Server, Form]),
+    select('openid.mode' = _, Form, Form1),
+    setup_call_cleanup(
+        http_open(Server, In,
+                  [ post(form([ 'openid.mode' = check_authentication
+                              | Form1
+                              ])),
+                    cert_verify_hook(ssl_verify)
+                  ]),
+        read_stream_to_codes(In, Reply),
+        close(In)),
+    debug(openid(check_authentication),
+          'Reply: ~n~s~n', [Reply]),
+    key_values_data(Pairs, Reply),
+    forall(member(invalidate_handle-Handle, Pairs),
+           retractall(association(_, Handle, _))),
+    memberchk(is_valid-true, Pairs).
+
+
+                 /*******************************
+                 *          AX HANDLING         *
+                 *******************************/
+
+%!  ax_options(+ServerOptions, +Options, +AXAttrs) is det.
+%
+%   True when AXAttrs is a  list   of  additional attribute exchange
+%   options to add to the OpenID redirect request.
+
+ax_options(ServerOptions, Options, AXAttrs) :-
+    option(ax(Spec), Options),
+    option(xrds_types(Types), ServerOptions),
+    memberchk('http://openid.net/srv/ax/1.0', Types),
+    !,
+    http_ax_attributes(Spec, AXAttrs),
+    debug(openid(ax), 'AX attributes: ~q', [AXAttrs]).
+ax_options(_, _, []) :-
+    debug(openid(ax), 'AX: not supported', []).
+
+%!  ax_store(+Form)
+%
+%   Extract reported AX data and  store   this  into the session. If
+%   there is a non-empty list of exchanged values, this calls
+%
+%       openid_hook(ax(Values))
+%
+%   If this hook fails, Values are added   to the session data using
+%   http_session_assert(ax(Values)).
+
+ax_store(Form) :-
+    debug(openid(ax), 'Form: ~q', [Form]),
+    ax_form_attributes(Form, Values),
+    debug(openid(ax), 'AX: ~q', [Values]),
+    (   Values \== []
+    ->  (   openid_hook(ax(Values))
+        ->  true
+        ;   http_session_assert(ax(Values))
+        )
+    ;   true
+    ).
+
+
+                 /*******************************
+                 *         OPENID SERVER        *
+                 *******************************/
+
+:- dynamic
+    server_association/3.           % URL, Handle, Term
+
+%!  openid_server(+Options, +Request)
+%
+%   Realise the OpenID server. The protocol   demands a POST request
+%   here.
+
+openid_server(Options, Request) :-
+    http_parameters(Request,
+                    [ 'openid.mode'(Mode)
+                    ],
+                    [ attribute_declarations(openid_attribute),
+                      form_data(Form)
+                    ]),
+    (   Mode == associate
+    ->  associate_server(Request, Form, Options)
+    ;   Mode == checkid_setup
+    ->  checkid_setup_server(Request, Form, Options)
+    ).
+
+%!  associate_server(+Request, +Form, +Options)
+%
+%   Handle the association-request. If successful,   create a clause
+%   for server_association/3 to record the current association.
+
+associate_server(Request, Form, Options) :-
+    memberchk('openid.assoc_type'         = AssocType,   Form),
+    memberchk('openid.session_type'       = SessionType, Form),
+    memberchk('openid.dh_modulus'         = P64,         Form),
+    memberchk('openid.dh_gen'             = G64,         Form),
+    memberchk('openid.dh_consumer_public' = CPX64,       Form),
+    base64_btwoc(P, P64),
+    base64_btwoc(G, G64),
+    base64_btwoc(CPX, CPX64),
+    Y is 1+random(P-1),             % Our secret
+    DiffieHellman is powm(CPX, Y, P),
+    btwoc(DiffieHellman, DHBytes),
+    signature_algorithm(SessionType, SHA_Algo),
+    sha_hash(DHBytes, SHA1, [encoding(octet), algorithm(SHA_Algo)]),
+    CPY is powm(G, Y, P),
+    base64_btwoc(CPY, CPY64),
+    mackey_bytes(SessionType, MacBytes),
+    new_assoc_handle(MacBytes, Handle),
+    random_bytes(MacBytes, MacKey),
+    xor_codes(MacKey, SHA1, EncKey),
+    phrase(base64(EncKey), Base64EncKey),
+    DefExpriresIn is 24*3600,
+    option(expires_in(ExpriresIn), Options, DefExpriresIn),
+
+    get_time(Now),
+    ExpiresAt is integer(Now+ExpriresIn),
+    make_association([ session_type(SessionType),
+                       expires_at(ExpiresAt),
+                       mac_key(MacKey)
+                     ],
+                     Record),
+    memberchk(peer(Peer), Request),
+    assert(server_association(Peer, Handle, Record)),
+
+    key_values_data([ assoc_type-AssocType,
+                      assoc_handle-Handle,
+                      expires_in-ExpriresIn,
+                      session_type-SessionType,
+                      dh_server_public-CPY64,
+                      enc_mac_key-Base64EncKey
+                    ],
+                    Text),
+    format('Content-type: text/plain~n~n~s', [Text]).
+
+mackey_bytes('DH-SHA1',   20).
+mackey_bytes('DH-SHA256', 32).
+
+new_assoc_handle(Length, Handle) :-
+    random_bytes(Length, Bytes),
+    phrase(base64(Bytes), HandleCodes),
+    atom_codes(Handle, HandleCodes).
+
+
+%!  checkid_setup_server(+Request, +Form, +Options)
+%
+%   Validate an OpenID for a TrustRoot and redirect the browser back
+%   to the ReturnTo argument.  There   are  many  possible scenarios
+%   here:
+%
+%           1. Check some cookie and if present, grant immediately
+%           2. Use a 401 challenge page
+%           3. Present a normal grant/password page
+%           4. As (3), but use HTTPS for the exchange
+%           5. etc.
+%
+%   First thing to check is the immediate acknowledgement.
+
+checkid_setup_server(_Request, Form, _Options) :-
+    memberchk('openid.identity'       = Identity,  Form),
+    memberchk('openid.assoc_handle'   = Handle,    Form),
+    memberchk('openid.return_to'      = ReturnTo,  Form),
+    (   memberchk('openid.realm'      = Realm,     Form) -> true
+    ;   memberchk('openid.trust_root' = Realm, Form)
+    ),
+
+    server_association(_, Handle, _Association),            % check
+
+    reply_html_page(
+        [ title('OpenID login')
+        ],
+        [ \openid_title,
+          div(class('openid-message'),
+              ['Site ', a(href(TrustRoot), TrustRoot),
+               ' requests permission to login with OpenID ',
+               a(href(Identity), Identity), '.'
+              ]),
+          table(class('openid-form'),
+                [ tr(td(form([ action(grant), method('GET') ],
+                             [ \hidden('openid.grant', yes),
+                               \hidden('openid.identity', Identity),
+                               \hidden('openid.assoc_handle', Handle),
+                               \hidden('openid.return_to', ReturnTo),
+                               \hidden('openid.realm', Realm),
+                               \hidden('openid.trust_root', Realm),
+                               div(['Password: ',
+                                    input([ type(password),
+                                            name('openid.password')
+                                          ]),
+                                    input([ type(submit),
+                                            value('Grant')
+                                          ])
+                                   ])
+                             ]))),
+                  tr(td(align(right),
+                        form([ action(grant), method('GET') ],
+                             [ \hidden('openid.grant', no),
+                               \hidden('openid.return_to', ReturnTo),
+                               input([type(submit), value('Deny')])
+                             ])))
+                ])
+        ]).
+
+hidden(Name, Value) -->
+    html(input([type(hidden), id(return_to), name(Name), value(Value)])).
+
+
+openid_title -->
+    { http_absolute_location(icons('openid-logo-square.png'), SRC, []) },
+    html_requires(css('openid.css')),
+    html(div(class('openid-title'),
+             [ a(href('http://openid.net/'),
+                 img([ src(SRC), alt('OpenID') ])),
+               span('Login')
+             ])).
+
+
+%!  openid_grant(+Request)
+%
+%   Handle the reply from checkid_setup_server/3.   If  the reply is
+%   =yes=, check the authority (typically the   password) and if all
+%   looks good redirect the browser to   ReturnTo, adding the OpenID
+%   properties needed by the Relying Party to verify the login.
+
+openid_grant(Request) :-
+    http_parameters(Request,
+                    [ 'openid.grant'(Grant),
+                      'openid.return_to'(ReturnTo)
+                    ],
+                    [ attribute_declarations(openid_attribute)
+                    ]),
+    (   Grant == yes
+    ->  http_parameters(Request,
+                        [ 'openid.identity'(Identity),
+                          'openid.assoc_handle'(Handle),
+                          'openid.trust_root'(TrustRoot),
+                          'openid.password'(Password)
+                        ],
+                        [ attribute_declarations(openid_attribute)
+                        ]),
+        server_association(_, Handle, Association),
+        grant_login(Request,
+                    [ identity(Identity),
+                      password(Password),
+                      trustroot(TrustRoot)
+                    ]),
+        SignedPairs = [ 'mode'-id_res,
+                        'identity'-Identity,
+                        'assoc_handle'-Handle,
+                        'return_to'-ReturnTo
+                      ],
+        signed_fields(SignedPairs, Signed),
+        signature(SignedPairs, Association, Signature),
+        phrase(base64(Signature), Bas64SigCodes),
+        string_codes(Bas64Sig, Bas64SigCodes),
+        redirect_browser(ReturnTo,
+                         [ 'openid.mode' = id_res,
+                           'openid.identity' = Identity,
+                           'openid.assoc_handle' = Handle,
+                           'openid.return_to' = ReturnTo,
+                           'openid.signed' = Signed,
+                           'openid.sig' = Bas64Sig
+                         ])
+    ;   redirect_browser(ReturnTo,
+                         [ 'openid.mode' = cancel
+                         ])
+    ).
+
+
+%!  grant_login(+Request, +Options) is det.
+%
+%   Validate login from Request (can  be   used  to get cookies) and
+%   Options, which contains at least:
+%
+%           * identity(Identity)
+%           * password(Password)
+%           * trustroot(TrustRoot)
+
+grant_login(Request, Options) :-
+    openid_hook(grant(Request, Options)).
+
+%!  trusted(+OpenID, +Server)
+%
+%   True if we  trust  the  given   OpenID  server.  Must  throw  an
+%   exception, possibly redirecting to a   page with trusted servers
+%   if the given server is not trusted.
+
+trusted(OpenID, Server) :-
+    openid_hook(trusted(OpenID, Server)).
+
+
+%!  signed_fields(+Pairs, -Signed) is det.
+%
+%   Create a comma-separated  atom  from   the  field-names  without
+%   'openid.' from Pairs.
+
+signed_fields(Pairs, Signed) :-
+    signed_field_names(Pairs, Names),
+    atomic_list_concat(Names, ',', Signed).
+
+signed_field_names([], []).
+signed_field_names([H0-_|T0], [H|T]) :-
+    (   atom_concat('openid.', H, H0)
+    ->  true
+    ;   H = H0
+    ),
+    signed_field_names(T0, T).
+
+%!  signature(+Pairs, +Association, -Signature)
+%
+%   Determine the signature for Pairs
+
+signature(Pairs, Association, Signature) :-
+    key_values_data(Pairs, TokenContents),
+    association_mac_key(Association, MacKey),
+    association_session_type(Association, SessionType),
+    signature_algorithm(SessionType, SHA),
+    hmac_sha(MacKey, TokenContents, Signature, [algorithm(SHA)]),
+    debug(openid(crypt),
+          'Signed:~n~s~nSignature: ~w', [TokenContents, Signature]).
+
+signature_algorithm('DH-SHA1',   sha1).
+signature_algorithm('DH-SHA256', sha256).
+
+
+                 /*******************************
+                 *            ASSOCIATE         *
+                 *******************************/
+
+:- dynamic
+    association/3.                  % URL, Handle, Data
+
+:- record
+    association(session_type='DH-SHA1',
+                expires_at,         % time-stamp
+                mac_key).           % code-list
+
+%!  openid_associate(?URL, ?Handle, ?Assoc) is det.
+%
+%   Calls openid_associate/4 as
+%
+%       ==
+%       openid_associate(URL, Handle, Assoc, []).
+%       ==
+
+openid_associate(URL, Handle, Assoc) :-
+    openid_associate(URL, Handle, Assoc, []).
+
+%!  openid_associate(+URL, -Handle, -Assoc, +Options) is det.
+%!  openid_associate(?URL, +Handle, -Assoc, +Options) is semidet.
+%
+%   Associate with an open-id server.  We   first  check for a still
+%   valid old association. If there is  none   or  it is expired, we
+%   establish one and remember it.  Options:
+%
+%     * ns(URL)
+%     One of =http://specs.openid.net/auth/2.0= (default) or
+%     =http://openid.net/signon/1.1=.
+%
+%   @tbd    Should we store known associations permanently?  Where?
+
+openid_associate(URL, Handle, Assoc, _Options) :-
+    nonvar(Handle),
+    !,
+    debug(openid(associate),
+          'OpenID: Lookup association with handle ~q', [Handle]),
+    (   association(URL, Handle, Assoc)
+    ->  true
+    ;   debug(openid(associate),
+              'OpenID: no association with handle ~q', [Handle]),
+        fail
+    ).
+openid_associate(URL, Handle, Assoc, _Options) :-
+    must_be(atom, URL),
+    association(URL, Handle, Assoc),
+    association_expires_at(Assoc, Expires),
+    get_time(Now),
+    (   Now < Expires
+    ->  !,
+        debug(openid(associate),
+              'OpenID: Reusing association with ~q', [URL])
+    ;   retractall(association(URL, Handle, _)),
+        fail
+    ).
+openid_associate(URL, Handle, Assoc, Options) :-
+    associate_data(Data, P, _G, X, Options),
+    debug(openid(associate), 'OpenID: Associating with ~q', [URL]),
+    setup_call_cleanup(
+        http_open(URL, In,
+                  [ post(form(Data)),
+                    cert_verify_hook(ssl_verify)
+                  ]),
+        read_stream_to_codes(In, Reply),
+        close(In)),
+    debug(openid(associate), 'Reply: ~n~s', [Reply]),
+    key_values_data(Pairs, Reply),
+    shared_secret(Pairs, P, X, MacKey),
+    expires_at(Pairs, ExpiresAt),
+    memberchk(assoc_handle-Handle, Pairs),
+    memberchk(session_type-Type, Pairs),
+    make_association([ session_type(Type),
+                       expires_at(ExpiresAt),
+                       mac_key(MacKey)
+                     ], Assoc),
+    assert(association(URL, Handle, Assoc)).
+
+
+%!  shared_secret(+Pairs, +P, +X, -Secret:list(codes))
+%
+%   Find the shared secret from the peer's reply and our data. First
+%   clause deals with the (deprecated) non-encoded version.
+
+shared_secret(Pairs, _, _, Secret) :-
+    memberchk(mac_key-Base64, Pairs),
+    !,
+    atom_codes(Base64, Base64Codes),
+    phrase(base64(Base64Codes), Secret).
+shared_secret(Pairs, P, X, Secret) :-
+    memberchk(dh_server_public-Base64Public, Pairs),
+    memberchk(enc_mac_key-Base64EncMacKey, Pairs),
+    memberchk(session_type-SessionType, Pairs),
+    base64_btwoc(ServerPublic, Base64Public),
+    DiffieHellman is powm(ServerPublic, X, P),
+    atom_codes(Base64EncMacKey, Base64EncMacKeyCodes),
+    phrase(base64(EncMacKey), Base64EncMacKeyCodes),
+    btwoc(DiffieHellman, DiffieHellmanBytes),
+    signature_algorithm(SessionType, SHA_Algo),
+    sha_hash(DiffieHellmanBytes, DHHash,
+             [encoding(octet), algorithm(SHA_Algo)]),
+    xor_codes(DHHash, EncMacKey, Secret).
+
+
+%!  expires_at(+Pairs, -Time) is det.
+%
+%   Unify Time with  a  time-stamp   stating  when  the  association
+%   exires.
+
+expires_at(Pairs, Time) :-
+    memberchk(expires_in-ExpAtom, Pairs),
+    atom_number(ExpAtom, Seconds),
+    get_time(Now),
+    Time is integer(Now)+Seconds.
+
+
+%!  associate_data(-Data, -P, -G, -X, +Options) is det.
+%
+%   Generate the data to initiate an association using Diffie-Hellman
+%   shared secret key negotiation.
+
+associate_data(Data, P, G, X, Options) :-
+    openid_dh_p(P),
+    openid_dh_g(G),
+    X is 1+random(P-1),                     % 1<=X<P-1
+    CP is powm(G, X, P),
+    base64_btwoc(P, P64),
+    base64_btwoc(G, G64),
+    base64_btwoc(CP, CP64),
+    option(ns(NS), Options, 'http://specs.openid.net/auth/2.0'),
+    (   assoc_type(NS, DefAssocType, DefSessionType)
+    ->  true
+    ;   domain_error('openid.ns', NS)
+    ),
+    option(assoc_type(AssocType), Options, DefAssocType),
+    option(assoc_type(SessionType), Options, DefSessionType),
+    Data = [ 'openid.ns'                 = NS,
+             'openid.mode'               = associate,
+             'openid.assoc_type'         = AssocType,
+             'openid.session_type'       = SessionType,
+             'openid.dh_modulus'         = P64,
+             'openid.dh_gen'             = G64,
+             'openid.dh_consumer_public' = CP64
+           ].
+
+assoc_type('http://specs.openid.net/auth/2.0',
+           'HMAC-SHA256',
+           'DH-SHA256').
+assoc_type('http://openid.net/signon/1.1',
+           'HMAC-SHA1',
+           'DH-SHA1').
+
+
+                 /*******************************
+                 *            RANDOM            *
+                 *******************************/
+
+%!  random_bytes(+N, -Bytes) is det.
+%
+%   Bytes is a list of N random bytes (integers 0..255).
+
+random_bytes(N, [H|T]) :-
+    N > 0,
+    !,
+    H is random(256),
+    N2 is N - 1,
+    random_bytes(N2, T).
+random_bytes(_, []).
+
+
+                 /*******************************
+                 *           CONSTANTS          *
+                 *******************************/
+
+openid_dh_p(155172898181473697471232257763715539915724801966915404479707795314057629378541917580651227423698188993727816152646631438561595825688188889951272158842675419950341258706556549803580104870537681476726513255747040765857479291291572334510643245094715007229621094194349783925984760375594985848253359305585439638443).
+
+openid_dh_g(2).
+
+
+                 /*******************************
+                 *             UTIL             *
+                 *******************************/
+
+%!  key_values_data(+KeyValues:list(Key-Value), -Data:list(code)) is det.
+%!  key_values_data(-KeyValues:list(Key-Value), +Data:list(code)) is det.
+%
+%   Encoding  and  decoding  of  key-value  pairs  for  OpenID  POST
+%   messages  according  to   Appendix   C    of   the   OpenID  1.1
+%   specification.
+
+key_values_data(Pairs, Data) :-
+    nonvar(Data),
+    !,
+    phrase(data_form(Pairs), Data).
+key_values_data(Pairs, Data) :-
+    phrase(gen_data_form(Pairs), Data).
+
+data_form([Key-Value|Pairs]) -->
+    utf8_string(KeyCodes), ":", utf8_string(ValueCodes), "\n",
+    !,
+    { atom_codes(Key, KeyCodes),
+      atom_codes(Value, ValueCodes)
+    },
+    data_form(Pairs).
+data_form([]) -->
+    ws.
+
+%!  utf8_string(-Codes)// is nondet.
+%
+%   Take a short UTF-8 code-list from input. Extend on backtracking.
+
+utf8_string([]) -->
+    [].
+utf8_string([H|T]) -->
+    utf8_codes([H]),
+    utf8_string(T).
+
+ws -->
+    [C],
+    { C =< 32 },
+    !,
+    ws.
+ws -->
+    [].
+
+
+gen_data_form([]) -->
+    [].
+gen_data_form([Key-Value|T]) -->
+    field(Key), ":", field(Value), "\n",
+    gen_data_form(T).
+
+field(Field) -->
+    { to_codes(Field, Codes)
+    },
+    utf8_codes(Codes).
+
+to_codes(Codes, Codes) :-
+    is_list(Codes),
+    !.
+to_codes(Atomic, Codes) :-
+    atom_codes(Atomic, Codes).
+
+%!  base64_btwoc(+Int, -Base64:list(code)) is det.
+%!  base64_btwoc(-Int, +Base64:list(code)) is det.
+%!  base64_btwoc(-Int, +Base64:atom) is det.
+
+base64_btwoc(Int, Base64) :-
+    integer(Int),
+    !,
+    btwoc(Int, Bytes),
+    phrase(base64(Bytes), Base64).
+base64_btwoc(Int, Base64) :-
+    atom(Base64),
+    !,
+    atom_codes(Base64, Codes),
+    phrase(base64(Bytes), Codes),
+    btwoc(Int, Bytes).
+base64_btwoc(Int, Base64) :-
+    phrase(base64(Bytes), Base64),
+    btwoc(Int, Bytes).
+
+
+%!  btwoc(+Integer, -Bytes) is det.
+%!  btwoc(-Integer, +Bytes) is det.
+%
+%   Translate between a big integer and and its representation in
+%   bytes.  The first bit is always 0, as Integer is nonneg.
+
+btwoc(Int, Bytes) :-
+    integer(Int),
+    !,
+    int_to_bytes(Int, Bytes).
+btwoc(Int, Bytes) :-
+    is_list(Bytes),
+    bytes_to_int(Bytes, Int).
+
+int_to_bytes(Int, Bytes) :-
+    int_to_bytes(Int, [], Bytes).
+
+int_to_bytes(Int, Bytes0, [Int|Bytes0]) :-
+    Int < 128,
+    !.
+int_to_bytes(Int, Bytes0, Bytes) :-
+    Last is Int /\ 0xff,
+    Int1 is Int >> 8,
+    int_to_bytes(Int1, [Last|Bytes0], Bytes).
+
+
+bytes_to_int([B|T], Int) :-
+    bytes_to_int(T, B, Int).
+
+bytes_to_int([], Int, Int).
+bytes_to_int([B|T], Int0, Int) :-
+    Int1 is (Int0<<8)+B,
+    bytes_to_int(T, Int1, Int).
+
+
+%!  xor_codes(+C1:list(int), +C2:list(int), -XOR:list(int)) is det.
+%
+%   Compute xor of two strings.
+%
+%   @error  length_mismatch(L1, L2) if the two lists do not have equal
+%           length.
+
+xor_codes([], [], []) :- !.
+xor_codes([H1|T1], [H2|T2], [H|T]) :-
+    !,
+    H is H1 xor H2,
+    !,
+    xor_codes(T1, T2, T).
+xor_codes(L1, L2, _) :-
+    throw(error(length_mismatch(L1, L2), _)).
+
+
+                 /*******************************
+                 *        HTTP ATTRIBUTES       *
+                 *******************************/
+
+openid_attribute('openid.mode',
+                 [ oneof([ associate,
+                           checkid_setup,
+                           cancel,
+                           id_res
+                         ])
+                 ]).
+openid_attribute('openid.assoc_type',
+                 [ oneof(['HMAC-SHA1'])
+                 ]).
+openid_attribute('openid.session_type',
+                 [ oneof([ 'DH-SHA1',
+                           'DH-SHA256'
+                         ])
+                 ]).
+openid_attribute('openid.dh_modulus',         [length > 1]).
+openid_attribute('openid.dh_gen',             [length > 1]).
+openid_attribute('openid.dh_consumer_public', [length > 1]).
+openid_attribute('openid.assoc_handle',       [length > 1]).
+openid_attribute('openid.return_to',          [length > 1]).
+openid_attribute('openid.trust_root',         [length > 1]).
+openid_attribute('openid.identity',           [length > 1]).
+openid_attribute('openid.password',           [length > 1]).
+openid_attribute('openid.grant',              [oneof([yes,no])]).