1/*  Part of SWI-Prolog
   2
   3    Author:        Jan Wielemaker
   4    E-mail:        J.Wielemaker@vu.nl
   5    WWW:           http://www.swi-prolog.org
   6    Copyright (c)  2010-2015, University of Amsterdam,
   7                              VU University Amsterdam
   8    All rights reserved.
   9
  10    Redistribution and use in source and binary forms, with or without
  11    modification, are permitted provided that the following conditions
  12    are met:
  13
  14    1. Redistributions of source code must retain the above copyright
  15       notice, this list of conditions and the following disclaimer.
  16
  17    2. Redistributions in binary form must reproduce the above copyright
  18       notice, this list of conditions and the following disclaimer in
  19       the documentation and/or other materials provided with the
  20       distribution.
  21
  22    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  23    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  24    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
  25    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
  26    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
  27    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
  28    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
  29    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
  30    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
  31    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
  32    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
  33    POSSIBILITY OF SUCH DAMAGE.
  34*/
  35
  36:- module(http_openid,
  37          [ openid_login/1,             % +OpenID
  38            openid_logout/1,            % +OpenID
  39            openid_logged_in/1,         % -OpenID
  40
  41                                        % transparent login
  42            openid_user/3,              % +Request, -User, +Options
  43
  44                                        % low-level primitives
  45            openid_verify/2,            % +Options, +Request
  46            openid_authenticate/4,      % +Request, -Server, -Identity, -ReturnTo
  47            openid_associate/3,         % +OpenIDServer, -Handle, -Association
  48            openid_associate/4,         % +OpenIDServer, -Handle, -Association,
  49                                        % +Options
  50            openid_server/2,            % +Options, +Request
  51            openid_server/3,            % ?OpenIDLogin, ?OpenID, ?Server
  52            openid_grant/1,             % +Request
  53
  54            openid_login_form//2,       % +ReturnTo, +Options, //
  55
  56            openid_current_url/2,       % +Request, -URL
  57            openid_current_host/3       % +Request, -Host, -Port
  58          ]).
  59:- use_module(library(http/http_open)).
  60:- use_module(library(http/html_write)).
  61:- use_module(library(http/http_parameters)).
  62:- use_module(library(http/http_dispatch)).
  63:- use_module(library(http/http_session)).
  64:- use_module(library(http/http_host)).
  65:- use_module(library(http/http_path)).
  66:- use_module(library(http/html_head)).
  67:- use_module(library(http/http_server_files), []).
  68:- use_module(library(http/yadis)).
  69:- use_module(library(http/ax)).
  70:- use_module(library(utf8)).
  71:- use_module(library(error)).
  72:- use_module(library(xpath)).
  73:- use_module(library(sgml)).
  74:- use_module(library(uri)).
  75:- use_module(library(occurs)).
  76:- use_module(library(base64)).
  77:- use_module(library(debug)).
  78:- use_module(library(record)).
  79:- use_module(library(option)).
  80:- use_module(library(sha)).
  81:- use_module(library(lists)).
  82:- use_module(library(settings)).
  83
  84:- predicate_options(openid_login_form/4, 2,
  85                     [ action(atom),
  86                       buttons(list),
  87                       show_stay(boolean)
  88                     ]).
  89:- predicate_options(openid_server/2, 1,
  90                     [ expires_in(any)
  91                     ]).
  92:- predicate_options(openid_user/3, 3,
  93                     [ login_url(atom)
  94                     ]).
  95:- predicate_options(openid_verify/2, 1,
  96                     [ return_to(atom),
  97                       trust_root(atom),
  98                       realm(atom),
  99                       ax(any)
 100                     ]).
 101
 102/** <module> OpenID consumer and server library
 103
 104This library implements the OpenID protocol (http://openid.net/). OpenID
 105is a protocol to share identities on   the  network. The protocol itself
 106uses simple basic  HTTP,  adding   reliability  using  digitally  signed
 107messages.
 108
 109Steps, as seen from the _consumer_ (or _|relying partner|_).
 110
 111        1. Show login form, asking for =openid_identifier=
 112        2. Get HTML page from =openid_identifier= and lookup
 113           =|<link rel="openid.server" href="server">|=
 114        3. Associate to _server_
 115        4. Redirect browser (302) to server using mode =checkid_setup=,
 116           asking to validate the given OpenID.
 117        5. OpenID server redirects back, providing digitally signed
 118           conformation of the claimed identity.
 119        6. Validate signature and redirect to the target location.
 120
 121A *consumer* (an application that allows OpenID login) typically uses
 122this library through openid_user/3. In addition, it must implement the
 123hook http_openid:openid_hook(trusted(OpenId, Server)) to define accepted
 124OpenID servers. Typically, this hook is used to provide a white-list of
 125aceptable servers. Note that accepting any OpenID server is possible,
 126but anyone on the internet can setup a dummy OpenID server that simply
 127grants and signs every request. Here is an example:
 128
 129    ==
 130    :- multifile http_openid:openid_hook/1.
 131
 132    http_openid:openid_hook(trusted(_, OpenIdServer)) :-
 133        (   trusted_server(OpenIdServer)
 134        ->  true
 135        ;   throw(http_reply(moved_temporary('/openid/trustedservers')))
 136        ).
 137
 138    trusted_server('http://www.myopenid.com/server').
 139    ==
 140
 141By default, information who is logged on  is maintained with the session
 142using http_session_assert/1 with the term   openid(Identity).  The hooks
 143login/logout/logged_in can be used to provide alternative administration
 144of logged-in users (e.g., based on client-IP, using cookies, etc.).
 145
 146To create a *server*,  you  must  do   four  things:  bind  the handlers
 147openid_server/2  and  openid_grant/1  to  HTTP    locations,  provide  a
 148user-page for registered users and   define  the grant(Request, Options)
 149hook to verify  your  users.  An  example   server  is  provided  in  in
 150<plbase>/doc/packages/examples/demo_openid.pl
 151*/
 152
 153                 /*******************************
 154                 *        CONFIGURATION         *
 155                 *******************************/
 156
 157http:location(openid, root(openid), [priority(-100)]).
 158
 159%!  openid_hook(+Action)
 160%
 161%   Call hook on the OpenID management library.  Defined hooks are:
 162%
 163%     * login(+OpenID)
 164%     Consider OpenID logged in.
 165%
 166%     * logout(+OpenID)
 167%     Logout OpenID
 168%
 169%     * logged_in(?OpenID)
 170%     True if OpenID is logged in
 171%
 172%     * grant(+Request, +Options)
 173%     Server: Reply positive on OpenID
 174%
 175%     * trusted(+OpenID, +Server)
 176%     True if Server is a trusted OpenID server
 177%
 178%     * ax(Values)
 179%     Called if the server provided AX attributes
 180%
 181%     * x_parameter(+Server, -Name, -Value)
 182%     Called to find additional HTTP parameters to send with the
 183%     OpenID verify request.
 184
 185:- multifile
 186    openid_hook/1.                  % +Action
 187
 188                 /*******************************
 189                 *       DIRECT LOGIN/OUT       *
 190                 *******************************/
 191
 192%!  openid_login(+OpenID) is det.
 193%
 194%   Associate the current  HTTP  session   with  OpenID.  If another
 195%   OpenID is already associated, this association is first removed.
 196
 197openid_login(OpenID) :-
 198    openid_hook(login(OpenID)),
 199    !,
 200    handle_stay_signed_in(OpenID).
 201openid_login(OpenID) :-
 202    openid_logout(_),
 203    http_session_assert(openid(OpenID)),
 204    handle_stay_signed_in(OpenID).
 205
 206%!  openid_logout(+OpenID) is det.
 207%
 208%   Remove the association of the current session with any OpenID
 209
 210openid_logout(OpenID) :-
 211    openid_hook(logout(OpenID)),
 212    !.
 213openid_logout(OpenID) :-
 214    http_session_retractall(openid(OpenID)).
 215
 216%!  openid_logged_in(-OpenID) is semidet.
 217%
 218%   True if session is associated with OpenID.
 219
 220openid_logged_in(OpenID) :-
 221    openid_hook(logged_in(OpenID)),
 222    !.
 223openid_logged_in(OpenID) :-
 224    http_in_session(_SessionId),            % test in session
 225    http_session_data(openid(OpenID)).
 226
 227
 228                 /*******************************
 229                 *            TOPLEVEL          *
 230                 *******************************/
 231
 232%!  openid_user(+Request:http_request, -OpenID:url, +Options) is det.
 233%
 234%   True if OpenID is a validated OpenID associated with the current
 235%   session. The scenario for which this predicate is designed is to
 236%   allow  an  HTTP  handler  that  requires    a   valid  login  to
 237%   use the transparent code below.
 238%
 239%     ==
 240%     handler(Request) :-
 241%           openid_user(Request, OpenID, []),
 242%           ...
 243%     ==
 244%
 245%   If the user is not yet logged on a sequence of redirects will
 246%   follow:
 247%
 248%     1. Show a page for login (default: page /openid/login),
 249%        predicate reply_openid_login/1)
 250%     2. By default, the OpenID login page is a form that is
 251%        submitted to the =verify=, which calls openid_verify/2.
 252%     3. openid_verify/2 does the following:
 253%        - Find the OpenID claimed identity and server
 254%        - Associate to the OpenID server
 255%        - redirects to the OpenID server for validation
 256%     4. The OpenID server will redirect here with the authetication
 257%        information.  This is handled by openid_authenticate/4.
 258%
 259%   Options:
 260%
 261%     * login_url(Login)
 262%       (Local) URL of page to enter OpenID information. Default
 263%       is the handler for openid_login_page/1
 264%
 265%   @see openid_authenticate/4 produces errors if login is invalid
 266%   or cancelled.
 267
 268:- http_handler(openid(login),        openid_login_page,   [priority(-10)]).
 269:- http_handler(openid(verify),       openid_verify([]),   []).
 270:- http_handler(openid(authenticate), openid_authenticate, []).
 271:- http_handler(openid(xrds),         openid_xrds,         []).
 272
 273openid_user(_Request, OpenID, _Options) :-
 274    openid_logged_in(OpenID),
 275    !.
 276openid_user(Request, _OpenID, Options) :-
 277    http_link_to_id(openid_login_page, [], DefLoginPage),
 278    option(login_url(LoginPage), Options, DefLoginPage),
 279    openid_current_url(Request, Here),
 280    redirect_browser(LoginPage,
 281                     [ 'openid.return_to' = Here
 282                     ]).
 283
 284%!  openid_xrds(Request)
 285%
 286%   Reply to a request  for   "Discovering  OpenID Relying Parties".
 287%   This may happen as part of  the provider verification procedure.
 288%   The  provider  will   do   a    Yadis   discovery   request   on
 289%   =openid.return=  or  =openid.realm=.  This  is    picked  up  by
 290%   openid_user/3, pointing the provider to   openid(xrds).  Now, we
 291%   reply with the locations marked =openid=  and the locations that
 292%   have actually been doing OpenID validations.
 293
 294openid_xrds(Request) :-
 295    http_link_to_id(openid_authenticate, [], Autheticate),
 296    public_url(Request, Autheticate, Public),
 297    format('Content-type: text/xml\n\n'),
 298    format('<?xml version="1.0" encoding="UTF-8"?>\n'),
 299    format('<xrds:XRDS\n'),
 300    format('    xmlns:xrds="xri://$xrds"\n'),
 301    format('    xmlns="xri://$xrd*($v*2.0)">\n'),
 302    format('  <XRD>\n'),
 303    format('    <Service>\n'),
 304    format('      <Type>http://specs.openid.net/auth/2.0/return_to</Type>\n'),
 305    format('      <URI>~w</URI>\n', [Public]),
 306    format('    </Service>\n'),
 307    format('  </XRD>\n'),
 308    format('</xrds:XRDS>\n').
 309
 310
 311%!  openid_login_page(+Request) is det.
 312%
 313%   Present a login-form for OpenID. There  are two ways to redefine
 314%   this  default  login  page.  One  is    to  provide  the  option
 315%   =login_url= to openid_user/3 and the other   is  to define a new
 316%   handler for =|/openid/login|= using http_handler/3.
 317
 318openid_login_page(Request) :-
 319    http_open_session(_, []),
 320    http_parameters(Request,
 321                    [ 'openid.return_to'(Target, [])
 322                    ]),
 323    reply_html_page([ title('OpenID login')
 324                    ],
 325                    [ \openid_login_form(Target, [])
 326                    ]).
 327
 328%!  openid_login_form(+ReturnTo, +Options)// is det.
 329%
 330%   Create the OpenID  form.  This  exported   as  a  seperate  DCG,
 331%   allowing applications to redefine /openid/login   and reuse this
 332%   part of the page.  Options processed:
 333%
 334%     - action(Action)
 335%     URL of action to call.  Default is the handler calling
 336%     openid_verify/1.
 337%     - buttons(+Buttons)
 338%     Buttons is a list of =img= structures where the =href=
 339%     points to an OpenID 2.0 endpoint.  These buttons are
 340%     displayed below the OpenID URL field.  Clicking the
 341%     button sets the URL field and submits the form.  Requires
 342%     Javascript support.
 343%
 344%     If the =href= is _relative_, clicking it opens the given
 345%     location after adding 'openid.return_to' and `stay'.
 346%     - show_stay(+Boolean)
 347%     If =true=, show a checkbox that allows the user to stay
 348%     logged on.
 349
 350openid_login_form(ReturnTo, Options) -->
 351    { http_link_to_id(openid_verify, [], VerifyLocation),
 352      option(action(Action), Options, VerifyLocation),
 353      http_session_retractall(openid(_)),
 354      http_session_retractall(openid_login(_,_,_,_)),
 355      http_session_retractall(ax(_))
 356    },
 357    html(div([ class('openid-login')
 358             ],
 359             [ \openid_title,
 360               form([ name(login),
 361                      id(login),
 362                      action(Action),
 363                      method('GET')
 364                    ],
 365                    [ \hidden('openid.return_to', ReturnTo),
 366                      div([ input([ class('openid-input'),
 367                                    name(openid_url),
 368                                    id(openid_url),
 369                                    size(30),
 370                                    placeholder('Your OpenID URL')
 371                                  ]),
 372                            input([ type(submit),
 373                                    value('Verify!')
 374                                  ])
 375                          ]),
 376                      \buttons(Options),
 377                      \stay_logged_on(Options)
 378                    ])
 379             ])).
 380
 381stay_logged_on(Options) -->
 382    { option(show_stay(true), Options) },
 383    !,
 384    html(div(class('openid-stay'),
 385             [ input([ type(checkbox), id(stay), name(stay), value(yes)]),
 386               'Stay signed in'
 387             ])).
 388stay_logged_on(_) --> [].
 389
 390buttons(Options) -->
 391    { option(buttons(Buttons), Options),
 392      Buttons \== []
 393    },
 394    html(div(class('openid-buttons'),
 395             [ 'Sign in with '
 396             | \prelogin_buttons(Buttons)
 397             ])).
 398buttons(_) --> [].
 399
 400prelogin_buttons([]) --> [].
 401prelogin_buttons([H|T]) --> prelogin_button(H), prelogin_buttons(T).
 402
 403%!  prelogin_button(+Image)// is det.
 404%
 405%   Handle OpenID 2.0 and other pre-login  buttons. If the image has
 406%   a =href= attribute that is absolute, it   is  taken as an OpenID
 407%   2.0 endpoint. Otherwise it is taken  as   a  link on the current
 408%   server. This allows us to present  non-OpenId logons in the same
 409%   screen. The dedicated  handler  is  passed  the  HTTP parameters
 410%   =openid.return_to= and =stay=.
 411
 412prelogin_button(img(Attrs)) -->
 413    { select_option(href(HREF), Attrs, RestAttrs),
 414      uri_is_global(HREF), !
 415    },
 416    html(img([ onClick('javascript:{$("#openid_url").val("'+HREF+'");'+
 417                       '$("form#login").submit();}'
 418                      )
 419                 | RestAttrs
 420             ])).
 421prelogin_button(img(Attrs)) -->
 422    { select_option(href(HREF), Attrs, RestAttrs)
 423    },
 424    html(img([ onClick('window.location = "'+HREF+
 425                       '?openid.return_to="'+
 426                       '+encodeURIComponent($("#return_to").val())'+
 427                       '+"&stay="'+
 428                       '+$("#stay").val()')
 429             | RestAttrs
 430             ])).
 431
 432
 433                 /*******************************
 434                 *          HTTP REPLIES        *
 435                 *******************************/
 436
 437%!  openid_verify(+Options, +Request)
 438%
 439%   Handle the initial login  form  presented   to  the  user by the
 440%   relying party (consumer). This predicate   discovers  the OpenID
 441%   server, associates itself with  this   server  and redirects the
 442%   user's  browser  to  the  OpenID  server,  providing  the  extra
 443%   openid.X name-value pairs. Options is,  against the conventions,
 444%   placed in front of the Request   to allow for smooth cooperation
 445%   with http_dispatch.pl.  Options processes:
 446%
 447%     * return_to(+URL)
 448%     Specifies where the OpenID provider should return to.
 449%     Normally, that is the current location.
 450%     * trust_root(+URL)
 451%     Specifies the =openid.trust_root= attribute.  Defaults to
 452%     the root of the current server (i.e., =|http://host[.port]/|=).
 453%     * realm(+URL)
 454%     Specifies the =openid.realm= attribute.  Default is the
 455%     =trust_root=.
 456%     * ax(+Spec)
 457%     Request the exchange of additional attributes from the
 458%     identity provider.  See http_ax_attributes/2 for details.
 459%
 460%   The OpenId server will redirect to the =openid.return_to= URL.
 461%
 462%   @throws http_reply(moved_temporary(Redirect))
 463
 464openid_verify(Options, Request) :-
 465    http_parameters(Request,
 466                    [ openid_url(URL, [length>1]),
 467                      'openid.return_to'(ReturnTo0, [optional(true)]),
 468                      stay(Stay, [optional(true), default(no)])
 469                    ]),
 470    (   option(return_to(ReturnTo1), Options)       % Option
 471    ->  openid_current_url(Request, CurrentLocation),
 472        global_url(ReturnTo1, CurrentLocation, ReturnTo)
 473    ;   nonvar(ReturnTo0)
 474    ->  ReturnTo = ReturnTo0                        % Form-data
 475    ;   openid_current_url(Request, CurrentLocation),
 476        ReturnTo = CurrentLocation                  % Current location
 477    ),
 478    public_url(Request, /, CurrentRoot),
 479    option(trust_root(TrustRoot), Options, CurrentRoot),
 480    option(realm(Realm), Options, TrustRoot),
 481    openid_resolve(URL, OpenIDLogin, OpenID, Server, ServerOptions),
 482    trusted(OpenID, Server),
 483    openid_associate(Server, Handle, _Assoc),
 484    assert_openid(OpenIDLogin, OpenID, Server, ReturnTo),
 485    stay(Stay),
 486    option(ns(NS), Options, 'http://specs.openid.net/auth/2.0'),
 487    (   realm_attribute(NS, RealmAttribute)
 488    ->  true
 489    ;   domain_error('openid.ns', NS)
 490    ),
 491    findall(P=V, openid_hook(x_parameter(Server, P, V)), XAttrs, AXAttrs),
 492    debug(openid(verify), 'XAttrs: ~p', [XAttrs]),
 493    ax_options(ServerOptions, Options, AXAttrs),
 494    http_link_to_id(openid_authenticate, [], AuthenticateLoc),
 495    public_url(Request, AuthenticateLoc, Authenticate),
 496    redirect_browser(Server, [ 'openid.ns'           = NS,
 497                               'openid.mode'         = checkid_setup,
 498                               'openid.identity'     = OpenID,
 499                               'openid.claimed_id'   = OpenID,
 500                               'openid.assoc_handle' = Handle,
 501                               'openid.return_to'    = Authenticate,
 502                               RealmAttribute        = Realm
 503                             | XAttrs
 504                             ]).
 505
 506realm_attribute('http://specs.openid.net/auth/2.0', 'openid.realm').
 507realm_attribute('http://openid.net/signon/1.1',     'openid.trust_root').
 508
 509
 510%!  stay(+Response)
 511%
 512%   Called if the user  ask  to  stay   signed  in.  This  is called
 513%   _before_ control is handed to the   OpenID server. It leaves the
 514%   data openid_stay_signed_in(true) in the current session.
 515
 516stay(yes) :-
 517    !,
 518    http_session_assert(openid_stay_signed_in(true)).
 519stay(_).
 520
 521%!  handle_stay_signed_in(+OpenID)
 522%
 523%   Handle stay_signed_in option after the user has logged on
 524
 525handle_stay_signed_in(OpenID) :-
 526    http_session_retract(openid_stay_signed_in(true)),
 527    !,
 528    http_set_session(timeout(0)),
 529    ignore(openid_hook(stay_signed_in(OpenID))).
 530handle_stay_signed_in(_).
 531
 532%!  assert_openid(+OpenIDLogin, +OpenID, +Server, +Target) is det.
 533%
 534%   Associate the OpenID  as  typed  by   the  user,  the  OpenID as
 535%   validated by the Server with the current HTTP session.
 536%
 537%   @param OpenIDLogin Canonized OpenID typed by user
 538%   @param OpenID OpenID verified by Server.
 539
 540assert_openid(OpenIDLogin, OpenID, Server, Target) :-
 541    openid_identifier_select_url(OpenIDLogin),
 542    openid_identifier_select_url(OpenID),
 543    !,
 544    assert_openid_in_session(openid_login(Identity, Identity, Server, Target)).
 545assert_openid(OpenIDLogin, OpenID, Server, Target) :-
 546    assert_openid_in_session(openid_login(OpenIDLogin, OpenID, Server, Target)).
 547
 548assert_openid_in_session(Term) :-
 549    (   http_in_session(Session)
 550    ->  debug(openid(verify), 'Assert ~p in ~p', [Term, Session])
 551    ;   debug(openid(verify), 'No session!', [])
 552    ),
 553    http_session_assert(Term).
 554
 555%!  openid_server(?OpenIDLogin, ?OpenID, ?Server) is nondet.
 556%
 557%   True if OpenIDLogin is the typed id for OpenID verified by
 558%   Server.
 559%
 560%   @param OpenIDLogin ID as typed by user (canonized)
 561%   @param OpenID ID as verified by server
 562%   @param Server URL of the OpenID server
 563
 564openid_server(OpenIDLogin, OpenID, Server) :-
 565    openid_server(OpenIDLogin, OpenID, Server, _Target).
 566
 567openid_server(OpenIDLogin, OpenID, Server, Target) :-
 568    http_in_session(Session),
 569    (   http_session_data(openid_login(OpenIDLogin, OpenID, Server, Target))
 570    ->  true
 571    ;   http_session_data(openid_login(OpenIDLogin1, OpenID1, Server1, Target1)),
 572        debug(openid(verify), '~p \\== ~p',
 573              [ openid_login(OpenIDLogin, OpenID, Server, Target),
 574                openid_login(OpenIDLogin1, OpenID1, Server1, Target1)
 575              ]),
 576        fail
 577    ;   debug(openid(verify), 'No openid_login/4 term in session ~p', [Session]),
 578        fail
 579    ).
 580
 581
 582%!  public_url(+Request, +Path, -URL) is det.
 583%
 584%   True when URL is a publically useable  URL that leads to Path on
 585%   the current server.
 586
 587public_url(Request, Path, URL) :-
 588    openid_current_host(Request, Host, Port),
 589    setting(http:public_scheme, Scheme),
 590    set_port(Scheme, Port, AuthC),
 591    uri_authority_data(host, AuthC, Host),
 592    uri_authority_components(Auth, AuthC),
 593    uri_data(scheme, Components, Scheme),
 594    uri_data(authority, Components, Auth),
 595    uri_data(path, Components, Path),
 596    uri_components(URL, Components).
 597
 598set_port(Scheme, Port, _) :-
 599    scheme_port(Scheme, Port),
 600    !.
 601set_port(_, Port, AuthC) :-
 602    uri_authority_data(port, AuthC, Port).
 603
 604scheme_port(http, 80).
 605scheme_port(https, 443).
 606
 607
 608%!  openid_current_url(+Request, -URL) is det.
 609%
 610%   @deprecated     New code should use http_public_url/2 with the
 611%                   same semantics.
 612
 613openid_current_url(Request, URL) :-
 614    http_public_url(Request, URL).
 615
 616%!  openid_current_host(Request, Host, Port)
 617%
 618%   Find current location of the server.
 619%
 620%   @deprecated     New code should use http_current_host/4 with the
 621%                   option global(true).
 622
 623openid_current_host(Request, Host, Port) :-
 624    http_current_host(Request, Host, Port,
 625                      [ global(true)
 626                      ]).
 627
 628
 629%!  redirect_browser(+URL, +FormExtra)
 630%
 631%   Generate a 302 temporary redirect to  URL, adding the extra form
 632%   information from FormExtra. The specs says   we  must retain the
 633%   search specification already attached to the URL.
 634
 635redirect_browser(URL, FormExtra) :-
 636    uri_components(URL, C0),
 637    uri_data(search, C0, Search0),
 638    (   var(Search0)
 639    ->  uri_query_components(Search, FormExtra)
 640    ;   uri_query_components(Search0, Form0),
 641        append(FormExtra, Form0, Form),
 642        uri_query_components(Search, Form)
 643    ),
 644    uri_data(search, C0, Search, C),
 645    uri_components(Redirect, C),
 646    throw(http_reply(moved_temporary(Redirect))).
 647
 648
 649                 /*******************************
 650                 *             RESOLVE          *
 651                 *******************************/
 652
 653%!  openid_resolve(+URL, -OpenIDOrig, -OpenID, -Server, -ServerOptions)
 654%
 655%   True if OpenID is the claimed  OpenID   that  belongs to URL and
 656%   Server is the URL of the  OpenID   server  that  can be asked to
 657%   verify this claim.
 658%
 659%   @param  URL The OpenID typed by the user
 660%   @param  OpenIDOrig Canonized OpenID typed by user
 661%   @param  OpenID Possibly delegated OpenID
 662%   @param  Server OpenID server that must validate OpenID
 663%   @param  ServerOptions provides additional XRDS information about
 664%           the server.  Currently supports xrds_types(Types).
 665%   @tbd    Implement complete URL canonization as defined by the
 666%           OpenID 2.0 proposal.
 667
 668openid_resolve(URL, OpenID, OpenID, Server, [xrds_types(Types)]) :-
 669    xrds_dom(URL, DOM),
 670    xpath(DOM, //(_:'Service'), Service),
 671    findall(Type, xpath(Service, _:'Type'(text), Type), Types),
 672    memberchk('http://specs.openid.net/auth/2.0/server', Types),
 673    xpath(Service, _:'URI'(text), Server),
 674    !,
 675    debug(openid(yadis), 'Yadis: server: ~q, types: ~q', [Server, Types]),
 676    (   xpath(Service, _:'LocalID'(text), OpenID)
 677    ->  true
 678    ;   openid_identifier_select_url(OpenID)
 679    ).
 680openid_resolve(URL, OpenID0, OpenID, Server, []) :-
 681    debug(openid(resolve), 'Opening ~w ...', [URL]),
 682    dtd(html, DTD),
 683    setup_call_cleanup(
 684        http_open(URL, Stream,
 685                  [ final_url(OpenID0),
 686                    cert_verify_hook(ssl_verify)
 687                  ]),
 688        load_structure(Stream, Term,
 689                       [ dtd(DTD),
 690                         dialect(sgml),
 691                         shorttag(false),
 692                         syntax_errors(quiet)
 693                       ]),
 694        close(Stream)),
 695    debug(openid(resolve), 'Scanning HTML document ...', [URL]),
 696    contains_term(element(head, _, Head), Term),
 697    (   link(Head, 'openid.server', Server)
 698    ->  debug(openid(resolve), 'OpenID Server=~q', [Server])
 699    ;   debug(openid(resolve), 'No server in ~q', [Head]),
 700        fail
 701    ),
 702    (   link(Head, 'openid.delegate', OpenID)
 703    ->  debug(openid(resolve), 'OpenID = ~q (delegated)', [OpenID])
 704    ;   OpenID = OpenID0,
 705        debug(openid(resolve), 'OpenID = ~q', [OpenID])
 706    ).
 707
 708openid_identifier_select_url(
 709    'http://specs.openid.net/auth/2.0/identifier_select').
 710
 711:- public ssl_verify/5.
 712
 713%!  ssl_verify(+SSL, +ProblemCert, +AllCerts, +FirstCert, +Error)
 714%
 715%   Accept all certificates. We do not care  too much. Only the user
 716%   cares s/he is not entering her  credentials with a spoofed side.
 717%   As we redirect, the browser will take care of this.
 718
 719ssl_verify(_SSL,
 720           _ProblemCertificate, _AllCertificates, _FirstCertificate,
 721           _Error).
 722
 723
 724link(DOM, Type, Target) :-
 725    sub_term(element(link, Attrs, []), DOM),
 726    memberchk(rel=Type, Attrs),
 727    memberchk(href=Target, Attrs).
 728
 729
 730                 /*******************************
 731                 *         AUTHENTICATE         *
 732                 *******************************/
 733
 734%!  openid_authenticate(+Request)
 735%
 736%   HTTP handler when redirected back from the OpenID provider.
 737
 738openid_authenticate(Request) :-
 739    memberchk(accept(Accept), Request),
 740    Accept = [media(application/'xrds+xml',_,_,_)],
 741    !,
 742    http_link_to_id(openid_xrds, [], XRDSLocation),
 743    http_absolute_uri(XRDSLocation, XRDSServer),
 744    debug(openid(yadis), 'Sending XRDS server: ~q', [XRDSServer]),
 745    format('X-XRDS-Location: ~w\n', [XRDSServer]),
 746    format('Content-type: text/plain\n\n').
 747openid_authenticate(Request) :-
 748    openid_authenticate(Request, _OpenIdServer, OpenID, _ReturnTo),
 749    openid_server(User, OpenID, _, Target),
 750    openid_login(User),
 751    redirect_browser(Target, []).
 752
 753
 754%!  openid_authenticate(+Request, -Server:url, -OpenID:url,
 755%!                      -ReturnTo:url) is semidet.
 756%
 757%   Succeeds if Request comes from the   OpenID  server and confirms
 758%   that User is a verified OpenID   user. ReturnTo provides the URL
 759%   to return to.
 760%
 761%   After openid_verify/2 has redirected the   browser to the OpenID
 762%   server, and the OpenID server did   its  magic, it redirects the
 763%   browser back to this address.  The   work  is fairly trivial. If
 764%   =mode= is =cancel=, the OpenId server   denied. If =id_res=, the
 765%   OpenId server replied positive, but  we   must  verify  what the
 766%   server told us by checking the HMAC-SHA signature.
 767%
 768%   This call fails silently if their is no =|openid.mode|= field in
 769%   the request.
 770%
 771%   @throws openid(cancel)
 772%           if request was cancelled by the OpenId server
 773%   @throws openid(signature_mismatch)
 774%           if the HMAC signature check failed
 775
 776openid_authenticate(Request, OpenIdServer, Identity, ReturnTo) :-
 777    memberchk(method(get), Request),
 778    http_parameters(Request,
 779                    [ 'openid.mode'(Mode, [optional(true)])
 780                    ]),
 781    (   var(Mode)
 782    ->  fail
 783    ;   Mode == cancel
 784    ->  throw(openid(cancel))
 785    ;   Mode == id_res
 786    ->  debug(openid(authenticate), 'Mode=id_res, validating response', []),
 787        http_parameters(Request,
 788                        [ 'openid.identity'(Identity, []),
 789                          'openid.assoc_handle'(Handle, []),
 790                          'openid.return_to'(ReturnTo, []),
 791                          'openid.signed'(AtomFields, []),
 792                          'openid.sig'(Base64Signature, []),
 793                          'openid.invalidate_handle'(Invalidate,
 794                                                     [optional(true)])
 795                        ],
 796                        [ form_data(Form)
 797                        ]),
 798        atomic_list_concat(SignedFields, ',', AtomFields),
 799        check_obligatory_fields(SignedFields),
 800        signed_pairs(SignedFields,
 801                     [ mode-Mode,
 802                       identity-Identity,
 803                       assoc_handle-Handle,
 804                       return_to-ReturnTo,
 805                       invalidate_handle-Invalidate
 806                     ],
 807                     Form,
 808                     SignedPairs),
 809        (   openid_associate(OpenIdServer, Handle, Assoc)
 810        ->  signature(SignedPairs, Assoc, Sig),
 811            atom_codes(Base64Signature, Base64SigCodes),
 812            phrase(base64(Signature), Base64SigCodes),
 813            (   Sig == Signature
 814            ->  true
 815            ;   throw(openid(signature_mismatch))
 816            )
 817        ;   check_authentication(Request, Form)
 818        ),
 819        ax_store(Form)
 820    ).
 821
 822%!  signed_pairs(+FieldNames, +Pairs:list(Field-Value),
 823%!               +Form, -SignedPairs) is det.
 824%
 825%   Extract the signed field in the order they appear in FieldNames.
 826
 827signed_pairs([], _, _, []).
 828signed_pairs([Field|T0], Pairs, Form, [Field-Value|T]) :-
 829    memberchk(Field-Value, Pairs),
 830    !,
 831    signed_pairs(T0, Pairs, Form, T).
 832signed_pairs([Field|T0], Pairs, Form, [Field-Value|T]) :-
 833    atom_concat('openid.', Field, OpenIdField),
 834    memberchk(OpenIdField=Value, Form),
 835    !,
 836    signed_pairs(T0, Pairs, Form, T).
 837signed_pairs([Field|T0], Pairs, Form, T) :-
 838    format(user_error, 'Form = ~p~n', [Form]),
 839    throw(error(existence_error(field, Field),
 840                context(_, 'OpenID Signed field is not present'))),
 841    signed_pairs(T0, Pairs, Form, T).
 842
 843
 844%!  check_obligatory_fields(+SignedFields:list) is det.
 845%
 846%   Verify fields from obligatory_field/1 are   in  the signed field
 847%   list.
 848%
 849%   @error  existence_error(field, Field)
 850
 851check_obligatory_fields(Fields) :-
 852    (   obligatory_field(Field),
 853        (   memberchk(Field, Fields)
 854        ->  true
 855        ;   throw(error(existence_error(field, Field),
 856                        context(_, 'OpenID field is not in signed fields')))
 857        ),
 858        fail
 859    ;   true
 860    ).
 861
 862obligatory_field(identity).
 863
 864
 865%!  check_authentication(+Request, +Form) is semidet.
 866%
 867%   Implement the stateless verification method.   This seems needed
 868%   for stackexchange.com, which provides the   =res_id=  with a new
 869%   association handle.
 870
 871check_authentication(_Request, Form) :-
 872    openid_server(_OpenIDLogin, _OpenID, Server),
 873    debug(openid(check_authentication),
 874          'Using stateless verification with ~q form~n~q', [Server, Form]),
 875    select('openid.mode' = _, Form, Form1),
 876    setup_call_cleanup(
 877        http_open(Server, In,
 878                  [ post(form([ 'openid.mode' = check_authentication
 879                              | Form1
 880                              ])),
 881                    cert_verify_hook(ssl_verify)
 882                  ]),
 883        read_stream_to_codes(In, Reply),
 884        close(In)),
 885    debug(openid(check_authentication),
 886          'Reply: ~n~s~n', [Reply]),
 887    key_values_data(Pairs, Reply),
 888    forall(member(invalidate_handle-Handle, Pairs),
 889           retractall(association(_, Handle, _))),
 890    memberchk(is_valid-true, Pairs).
 891
 892
 893                 /*******************************
 894                 *          AX HANDLING         *
 895                 *******************************/
 896
 897%!  ax_options(+ServerOptions, +Options, +AXAttrs) is det.
 898%
 899%   True when AXAttrs is a  list   of  additional attribute exchange
 900%   options to add to the OpenID redirect request.
 901
 902ax_options(ServerOptions, Options, AXAttrs) :-
 903    option(ax(Spec), Options),
 904    option(xrds_types(Types), ServerOptions),
 905    memberchk('http://openid.net/srv/ax/1.0', Types),
 906    !,
 907    http_ax_attributes(Spec, AXAttrs),
 908    debug(openid(ax), 'AX attributes: ~q', [AXAttrs]).
 909ax_options(_, _, []) :-
 910    debug(openid(ax), 'AX: not supported', []).
 911
 912%!  ax_store(+Form)
 913%
 914%   Extract reported AX data and  store   this  into the session. If
 915%   there is a non-empty list of exchanged values, this calls
 916%
 917%       openid_hook(ax(Values))
 918%
 919%   If this hook fails, Values are added   to the session data using
 920%   http_session_assert(ax(Values)).
 921
 922ax_store(Form) :-
 923    debug(openid(ax), 'Form: ~q', [Form]),
 924    ax_form_attributes(Form, Values),
 925    debug(openid(ax), 'AX: ~q', [Values]),
 926    (   Values \== []
 927    ->  (   openid_hook(ax(Values))
 928        ->  true
 929        ;   http_session_assert(ax(Values))
 930        )
 931    ;   true
 932    ).
 933
 934
 935                 /*******************************
 936                 *         OPENID SERVER        *
 937                 *******************************/
 938
 939:- dynamic
 940    server_association/3.           % URL, Handle, Term
 941
 942%!  openid_server(+Options, +Request)
 943%
 944%   Realise the OpenID server. The protocol   demands a POST request
 945%   here.
 946
 947openid_server(Options, Request) :-
 948    http_parameters(Request,
 949                    [ 'openid.mode'(Mode)
 950                    ],
 951                    [ attribute_declarations(openid_attribute),
 952                      form_data(Form)
 953                    ]),
 954    (   Mode == associate
 955    ->  associate_server(Request, Form, Options)
 956    ;   Mode == checkid_setup
 957    ->  checkid_setup_server(Request, Form, Options)
 958    ).
 959
 960%!  associate_server(+Request, +Form, +Options)
 961%
 962%   Handle the association-request. If successful,   create a clause
 963%   for server_association/3 to record the current association.
 964
 965associate_server(Request, Form, Options) :-
 966    memberchk('openid.assoc_type'         = AssocType,   Form),
 967    memberchk('openid.session_type'       = SessionType, Form),
 968    memberchk('openid.dh_modulus'         = P64,         Form),
 969    memberchk('openid.dh_gen'             = G64,         Form),
 970    memberchk('openid.dh_consumer_public' = CPX64,       Form),
 971    base64_btwoc(P, P64),
 972    base64_btwoc(G, G64),
 973    base64_btwoc(CPX, CPX64),
 974    Y is 1+random(P-1),             % Our secret
 975    DiffieHellman is powm(CPX, Y, P),
 976    btwoc(DiffieHellman, DHBytes),
 977    signature_algorithm(SessionType, SHA_Algo),
 978    sha_hash(DHBytes, SHA1, [encoding(octet), algorithm(SHA_Algo)]),
 979    CPY is powm(G, Y, P),
 980    base64_btwoc(CPY, CPY64),
 981    mackey_bytes(SessionType, MacBytes),
 982    new_assoc_handle(MacBytes, Handle),
 983    random_bytes(MacBytes, MacKey),
 984    xor_codes(MacKey, SHA1, EncKey),
 985    phrase(base64(EncKey), Base64EncKey),
 986    DefExpriresIn is 24*3600,
 987    option(expires_in(ExpriresIn), Options, DefExpriresIn),
 988
 989    get_time(Now),
 990    ExpiresAt is integer(Now+ExpriresIn),
 991    make_association([ session_type(SessionType),
 992                       expires_at(ExpiresAt),
 993                       mac_key(MacKey)
 994                     ],
 995                     Record),
 996    memberchk(peer(Peer), Request),
 997    assert(server_association(Peer, Handle, Record)),
 998
 999    key_values_data([ assoc_type-AssocType,
1000                      assoc_handle-Handle,
1001                      expires_in-ExpriresIn,
1002                      session_type-SessionType,
1003                      dh_server_public-CPY64,
1004                      enc_mac_key-Base64EncKey
1005                    ],
1006                    Text),
1007    format('Content-type: text/plain~n~n~s', [Text]).
1008
1009mackey_bytes('DH-SHA1',   20).
1010mackey_bytes('DH-SHA256', 32).
1011
1012new_assoc_handle(Length, Handle) :-
1013    random_bytes(Length, Bytes),
1014    phrase(base64(Bytes), HandleCodes),
1015    atom_codes(Handle, HandleCodes).
1016
1017
1018%!  checkid_setup_server(+Request, +Form, +Options)
1019%
1020%   Validate an OpenID for a TrustRoot and redirect the browser back
1021%   to the ReturnTo argument.  There   are  many  possible scenarios
1022%   here:
1023%
1024%           1. Check some cookie and if present, grant immediately
1025%           2. Use a 401 challenge page
1026%           3. Present a normal grant/password page
1027%           4. As (3), but use HTTPS for the exchange
1028%           5. etc.
1029%
1030%   First thing to check is the immediate acknowledgement.
1031
1032checkid_setup_server(_Request, Form, _Options) :-
1033    memberchk('openid.identity'       = Identity,  Form),
1034    memberchk('openid.assoc_handle'   = Handle,    Form),
1035    memberchk('openid.return_to'      = ReturnTo,  Form),
1036    (   memberchk('openid.realm'      = Realm,     Form) -> true
1037    ;   memberchk('openid.trust_root' = Realm, Form)
1038    ),
1039
1040    server_association(_, Handle, _Association),            % check
1041
1042    reply_html_page(
1043        [ title('OpenID login')
1044        ],
1045        [ \openid_title,
1046          div(class('openid-message'),
1047              ['Site ', a(href(TrustRoot), TrustRoot),
1048               ' requests permission to login with OpenID ',
1049               a(href(Identity), Identity), '.'
1050              ]),
1051          table(class('openid-form'),
1052                [ tr(td(form([ action(grant), method('GET') ],
1053                             [ \hidden('openid.grant', yes),
1054                               \hidden('openid.identity', Identity),
1055                               \hidden('openid.assoc_handle', Handle),
1056                               \hidden('openid.return_to', ReturnTo),
1057                               \hidden('openid.realm', Realm),
1058                               \hidden('openid.trust_root', Realm),
1059                               div(['Password: ',
1060                                    input([ type(password),
1061                                            name('openid.password')
1062                                          ]),
1063                                    input([ type(submit),
1064                                            value('Grant')
1065                                          ])
1066                                   ])
1067                             ]))),
1068                  tr(td(align(right),
1069                        form([ action(grant), method('GET') ],
1070                             [ \hidden('openid.grant', no),
1071                               \hidden('openid.return_to', ReturnTo),
1072                               input([type(submit), value('Deny')])
1073                             ])))
1074                ])
1075        ]).
1076
1077hidden(Name, Value) -->
1078    html(input([type(hidden), id(return_to), name(Name), value(Value)])).
1079
1080
1081openid_title -->
1082    { http_absolute_location(icons('openid-logo-square.png'), SRC, []) },
1083    html_requires(css('openid.css')),
1084    html(div(class('openid-title'),
1085             [ a(href('http://openid.net/'),
1086                 img([ src(SRC), alt('OpenID') ])),
1087               span('Login')
1088             ])).
1089
1090
1091%!  openid_grant(+Request)
1092%
1093%   Handle the reply from checkid_setup_server/3.   If  the reply is
1094%   =yes=, check the authority (typically the   password) and if all
1095%   looks good redirect the browser to   ReturnTo, adding the OpenID
1096%   properties needed by the Relying Party to verify the login.
1097
1098openid_grant(Request) :-
1099    http_parameters(Request,
1100                    [ 'openid.grant'(Grant),
1101                      'openid.return_to'(ReturnTo)
1102                    ],
1103                    [ attribute_declarations(openid_attribute)
1104                    ]),
1105    (   Grant == yes
1106    ->  http_parameters(Request,
1107                        [ 'openid.identity'(Identity),
1108                          'openid.assoc_handle'(Handle),
1109                          'openid.trust_root'(TrustRoot),
1110                          'openid.password'(Password)
1111                        ],
1112                        [ attribute_declarations(openid_attribute)
1113                        ]),
1114        server_association(_, Handle, Association),
1115        grant_login(Request,
1116                    [ identity(Identity),
1117                      password(Password),
1118                      trustroot(TrustRoot)
1119                    ]),
1120        SignedPairs = [ 'mode'-id_res,
1121                        'identity'-Identity,
1122                        'assoc_handle'-Handle,
1123                        'return_to'-ReturnTo
1124                      ],
1125        signed_fields(SignedPairs, Signed),
1126        signature(SignedPairs, Association, Signature),
1127        phrase(base64(Signature), Bas64SigCodes),
1128        string_codes(Bas64Sig, Bas64SigCodes),
1129        redirect_browser(ReturnTo,
1130                         [ 'openid.mode' = id_res,
1131                           'openid.identity' = Identity,
1132                           'openid.assoc_handle' = Handle,
1133                           'openid.return_to' = ReturnTo,
1134                           'openid.signed' = Signed,
1135                           'openid.sig' = Bas64Sig
1136                         ])
1137    ;   redirect_browser(ReturnTo,
1138                         [ 'openid.mode' = cancel
1139                         ])
1140    ).
1141
1142
1143%!  grant_login(+Request, +Options) is det.
1144%
1145%   Validate login from Request (can  be   used  to get cookies) and
1146%   Options, which contains at least:
1147%
1148%           * identity(Identity)
1149%           * password(Password)
1150%           * trustroot(TrustRoot)
1151
1152grant_login(Request, Options) :-
1153    openid_hook(grant(Request, Options)).
1154
1155%!  trusted(+OpenID, +Server)
1156%
1157%   True if we  trust  the  given   OpenID  server.  Must  throw  an
1158%   exception, possibly redirecting to a   page with trusted servers
1159%   if the given server is not trusted.
1160
1161trusted(OpenID, Server) :-
1162    openid_hook(trusted(OpenID, Server)).
1163
1164
1165%!  signed_fields(+Pairs, -Signed) is det.
1166%
1167%   Create a comma-separated  atom  from   the  field-names  without
1168%   'openid.' from Pairs.
1169
1170signed_fields(Pairs, Signed) :-
1171    signed_field_names(Pairs, Names),
1172    atomic_list_concat(Names, ',', Signed).
1173
1174signed_field_names([], []).
1175signed_field_names([H0-_|T0], [H|T]) :-
1176    (   atom_concat('openid.', H, H0)
1177    ->  true
1178    ;   H = H0
1179    ),
1180    signed_field_names(T0, T).
1181
1182%!  signature(+Pairs, +Association, -Signature)
1183%
1184%   Determine the signature for Pairs
1185
1186signature(Pairs, Association, Signature) :-
1187    key_values_data(Pairs, TokenContents),
1188    association_mac_key(Association, MacKey),
1189    association_session_type(Association, SessionType),
1190    signature_algorithm(SessionType, SHA),
1191    hmac_sha(MacKey, TokenContents, Signature, [algorithm(SHA)]),
1192    debug(openid(crypt),
1193          'Signed:~n~s~nSignature: ~w', [TokenContents, Signature]).
1194
1195signature_algorithm('DH-SHA1',   sha1).
1196signature_algorithm('DH-SHA256', sha256).
1197
1198
1199                 /*******************************
1200                 *            ASSOCIATE         *
1201                 *******************************/
1202
1203:- dynamic
1204    association/3.                  % URL, Handle, Data
1205
1206:- record
1207    association(session_type='DH-SHA1',
1208                expires_at,         % time-stamp
1209                mac_key).           % code-list
1210
1211%!  openid_associate(?URL, ?Handle, ?Assoc) is det.
1212%
1213%   Calls openid_associate/4 as
1214%
1215%       ==
1216%       openid_associate(URL, Handle, Assoc, []).
1217%       ==
1218
1219openid_associate(URL, Handle, Assoc) :-
1220    openid_associate(URL, Handle, Assoc, []).
1221
1222%!  openid_associate(+URL, -Handle, -Assoc, +Options) is det.
1223%!  openid_associate(?URL, +Handle, -Assoc, +Options) is semidet.
1224%
1225%   Associate with an open-id server.  We   first  check for a still
1226%   valid old association. If there is  none   or  it is expired, we
1227%   esstablish one and remember it.  Options:
1228%
1229%     * ns(URL)
1230%     One of =http://specs.openid.net/auth/2.0= (default) or
1231%     =http://openid.net/signon/1.1=.
1232%
1233%   @tbd    Should we store known associations permanently?  Where?
1234
1235openid_associate(URL, Handle, Assoc, _Options) :-
1236    nonvar(Handle),
1237    !,
1238    debug(openid(associate),
1239          'OpenID: Lookup association with handle ~q', [Handle]),
1240    (   association(URL, Handle, Assoc)
1241    ->  true
1242    ;   debug(openid(associate),
1243              'OpenID: no association with handle ~q', [Handle]),
1244        fail
1245    ).
1246openid_associate(URL, Handle, Assoc, _Options) :-
1247    must_be(atom, URL),
1248    association(URL, Handle, Assoc),
1249    association_expires_at(Assoc, Expires),
1250    get_time(Now),
1251    (   Now < Expires
1252    ->  !,
1253        debug(openid(associate),
1254              'OpenID: Reusing association with ~q', [URL])
1255    ;   retractall(association(URL, Handle, _)),
1256        fail
1257    ).
1258openid_associate(URL, Handle, Assoc, Options) :-
1259    associate_data(Data, P, _G, X, Options),
1260    debug(openid(associate), 'OpenID: Associating with ~q', [URL]),
1261    setup_call_cleanup(
1262        http_open(URL, In,
1263                  [ post(form(Data)),
1264                    cert_verify_hook(ssl_verify)
1265                  ]),
1266        read_stream_to_codes(In, Reply),
1267        close(In)),
1268    debug(openid(associate), 'Reply: ~n~s', [Reply]),
1269    key_values_data(Pairs, Reply),
1270    shared_secret(Pairs, P, X, MacKey),
1271    expires_at(Pairs, ExpiresAt),
1272    memberchk(assoc_handle-Handle, Pairs),
1273    memberchk(session_type-Type, Pairs),
1274    make_association([ session_type(Type),
1275                       expires_at(ExpiresAt),
1276                       mac_key(MacKey)
1277                     ], Assoc),
1278    assert(association(URL, Handle, Assoc)).
1279
1280
1281%!  shared_secret(+Pairs, +P, +X, -Secret:list(codes))
1282%
1283%   Find the shared secret from the peer's reply and our data. First
1284%   clause deals with the (deprecated) non-encoded version.
1285
1286shared_secret(Pairs, _, _, Secret) :-
1287    memberchk(mac_key-Base64, Pairs),
1288    !,
1289    atom_codes(Base64, Base64Codes),
1290    phrase(base64(Base64Codes), Secret).
1291shared_secret(Pairs, P, X, Secret) :-
1292    memberchk(dh_server_public-Base64Public, Pairs),
1293    memberchk(enc_mac_key-Base64EncMacKey, Pairs),
1294    memberchk(session_type-SessionType, Pairs),
1295    base64_btwoc(ServerPublic, Base64Public),
1296    DiffieHellman is powm(ServerPublic, X, P),
1297    atom_codes(Base64EncMacKey, Base64EncMacKeyCodes),
1298    phrase(base64(EncMacKey), Base64EncMacKeyCodes),
1299    btwoc(DiffieHellman, DiffieHellmanBytes),
1300    signature_algorithm(SessionType, SHA_Algo),
1301    sha_hash(DiffieHellmanBytes, DHHash,
1302             [encoding(octet), algorithm(SHA_Algo)]),
1303    xor_codes(DHHash, EncMacKey, Secret).
1304
1305
1306%!  expires_at(+Pairs, -Time) is det.
1307%
1308%   Unify Time with  a  time-stamp   stating  when  the  association
1309%   exires.
1310
1311expires_at(Pairs, Time) :-
1312    memberchk(expires_in-ExpAtom, Pairs),
1313    atom_number(ExpAtom, Seconds),
1314    get_time(Now),
1315    Time is integer(Now)+Seconds.
1316
1317
1318%!  associate_data(-Data, -P, -G, -X, +Options) is det.
1319%
1320%   Generate the data to initiate an association using Diffie-Hellman
1321%   shared secret key negotiation.
1322
1323associate_data(Data, P, G, X, Options) :-
1324    openid_dh_p(P),
1325    openid_dh_g(G),
1326    X is 1+random(P-1),                     % 1<=X<P-1
1327    CP is powm(G, X, P),
1328    base64_btwoc(P, P64),
1329    base64_btwoc(G, G64),
1330    base64_btwoc(CP, CP64),
1331    option(ns(NS), Options, 'http://specs.openid.net/auth/2.0'),
1332    (   assoc_type(NS, DefAssocType, DefSessionType)
1333    ->  true
1334    ;   domain_error('openid.ns', NS)
1335    ),
1336    option(assoc_type(AssocType), Options, DefAssocType),
1337    option(assoc_type(SessionType), Options, DefSessionType),
1338    Data = [ 'openid.ns'                 = NS,
1339             'openid.mode'               = associate,
1340             'openid.assoc_type'         = AssocType,
1341             'openid.session_type'       = SessionType,
1342             'openid.dh_modulus'         = P64,
1343             'openid.dh_gen'             = G64,
1344             'openid.dh_consumer_public' = CP64
1345           ].
1346
1347assoc_type('http://specs.openid.net/auth/2.0',
1348           'HMAC-SHA256',
1349           'DH-SHA256').
1350assoc_type('http://openid.net/signon/1.1',
1351           'HMAC-SHA1',
1352           'DH-SHA1').
1353
1354
1355                 /*******************************
1356                 *            RANDOM            *
1357                 *******************************/
1358
1359%!  random_bytes(+N, -Bytes) is det.
1360%
1361%   Bytes is a list of N random bytes (integers 0..255).
1362
1363random_bytes(N, [H|T]) :-
1364    N > 0,
1365    !,
1366    H is random(256),
1367    N2 is N - 1,
1368    random_bytes(N2, T).
1369random_bytes(_, []).
1370
1371
1372                 /*******************************
1373                 *           CONSTANTS          *
1374                 *******************************/
1375
1376openid_dh_p(155172898181473697471232257763715539915724801966915404479707795314057629378541917580651227423698188993727816152646631438561595825688188889951272158842675419950341258706556549803580104870537681476726513255747040765857479291291572334510643245094715007229621094194349783925984760375594985848253359305585439638443).
1377
1378openid_dh_g(2).
1379
1380
1381                 /*******************************
1382                 *             UTIL             *
1383                 *******************************/
1384
1385%!  key_values_data(+KeyValues:list(Key-Value), -Data:list(code)) is det.
1386%!  key_values_data(-KeyValues:list(Key-Value), +Data:list(code)) is det.
1387%
1388%   Encoding  and  decoding  of  key-value  pairs  for  OpenID  POST
1389%   messages  according  to   Appendix   C    of   the   OpenID  1.1
1390%   specification.
1391
1392key_values_data(Pairs, Data) :-
1393    nonvar(Data),
1394    !,
1395    phrase(data_form(Pairs), Data).
1396key_values_data(Pairs, Data) :-
1397    phrase(gen_data_form(Pairs), Data).
1398
1399data_form([Key-Value|Pairs]) -->
1400    utf8_string(KeyCodes), ":", utf8_string(ValueCodes), "\n",
1401    !,
1402    { atom_codes(Key, KeyCodes),
1403      atom_codes(Value, ValueCodes)
1404    },
1405    data_form(Pairs).
1406data_form([]) -->
1407    ws.
1408
1409%!  utf8_string(-Codes)// is nondet.
1410%
1411%   Take a short UTF-8 code-list from input. Extend on backtracking.
1412
1413utf8_string([]) -->
1414    [].
1415utf8_string([H|T]) -->
1416    utf8_codes([H]),
1417    utf8_string(T).
1418
1419ws -->
1420    [C],
1421    { C =< 32 },
1422    !,
1423    ws.
1424ws -->
1425    [].
1426
1427
1428gen_data_form([]) -->
1429    [].
1430gen_data_form([Key-Value|T]) -->
1431    field(Key), ":", field(Value), "\n",
1432    gen_data_form(T).
1433
1434field(Field) -->
1435    { to_codes(Field, Codes)
1436    },
1437    utf8_codes(Codes).
1438
1439to_codes(Codes, Codes) :-
1440    is_list(Codes),
1441    !.
1442to_codes(Atomic, Codes) :-
1443    atom_codes(Atomic, Codes).
1444
1445%!  base64_btwoc(+Int, -Base64:list(code)) is det.
1446%!  base64_btwoc(-Int, +Base64:list(code)) is det.
1447%!  base64_btwoc(-Int, +Base64:atom) is det.
1448
1449base64_btwoc(Int, Base64) :-
1450    integer(Int),
1451    !,
1452    btwoc(Int, Bytes),
1453    phrase(base64(Bytes), Base64).
1454base64_btwoc(Int, Base64) :-
1455    atom(Base64),
1456    !,
1457    atom_codes(Base64, Codes),
1458    phrase(base64(Bytes), Codes),
1459    btwoc(Int, Bytes).
1460base64_btwoc(Int, Base64) :-
1461    phrase(base64(Bytes), Base64),
1462    btwoc(Int, Bytes).
1463
1464
1465%!  btwoc(+Integer, -Bytes) is det.
1466%!  btwoc(-Integer, +Bytes) is det.
1467%
1468%   Translate between a big integer and and its representation in
1469%   bytes.  The first bit is always 0, as Integer is nonneg.
1470
1471btwoc(Int, Bytes) :-
1472    integer(Int),
1473    !,
1474    int_to_bytes(Int, Bytes).
1475btwoc(Int, Bytes) :-
1476    is_list(Bytes),
1477    bytes_to_int(Bytes, Int).
1478
1479int_to_bytes(Int, Bytes) :-
1480    int_to_bytes(Int, [], Bytes).
1481
1482int_to_bytes(Int, Bytes0, [Int|Bytes0]) :-
1483    Int < 128,
1484    !.
1485int_to_bytes(Int, Bytes0, Bytes) :-
1486    Last is Int /\ 0xff,
1487    Int1 is Int >> 8,
1488    int_to_bytes(Int1, [Last|Bytes0], Bytes).
1489
1490
1491bytes_to_int([B|T], Int) :-
1492    bytes_to_int(T, B, Int).
1493
1494bytes_to_int([], Int, Int).
1495bytes_to_int([B|T], Int0, Int) :-
1496    Int1 is (Int0<<8)+B,
1497    bytes_to_int(T, Int1, Int).
1498
1499
1500%!  xor_codes(+C1:list(int), +C2:list(int), -XOR:list(int)) is det.
1501%
1502%   Compute xor of two strings.
1503%
1504%   @error  length_mismatch(L1, L2) if the two lists do not have equal
1505%           length.
1506
1507xor_codes([], [], []) :- !.
1508xor_codes([H1|T1], [H2|T2], [H|T]) :-
1509    !,
1510    H is H1 xor H2,
1511    !,
1512    xor_codes(T1, T2, T).
1513xor_codes(L1, L2, _) :-
1514    throw(error(length_mismatch(L1, L2), _)).
1515
1516
1517                 /*******************************
1518                 *        HTTP ATTRIBUTES       *
1519                 *******************************/
1520
1521openid_attribute('openid.mode',
1522                 [ oneof([ associate,
1523                           checkid_setup,
1524                           cancel,
1525                           id_res
1526                         ])
1527                 ]).
1528openid_attribute('openid.assoc_type',
1529                 [ oneof(['HMAC-SHA1'])
1530                 ]).
1531openid_attribute('openid.session_type',
1532                 [ oneof([ 'DH-SHA1',
1533                           'DH-SHA256'
1534                         ])
1535                 ]).
1536openid_attribute('openid.dh_modulus',         [length > 1]).
1537openid_attribute('openid.dh_gen',             [length > 1]).
1538openid_attribute('openid.dh_consumer_public', [length > 1]).
1539openid_attribute('openid.assoc_handle',       [length > 1]).
1540openid_attribute('openid.return_to',          [length > 1]).
1541openid_attribute('openid.trust_root',         [length > 1]).
1542openid_attribute('openid.identity',           [length > 1]).
1543openid_attribute('openid.password',           [length > 1]).
1544openid_attribute('openid.grant',              [oneof([yes,no])]).