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
  125acceptable 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  separate  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%   Find the public URL for Request that   we  can make available to our
  611%   identity provider. This must be an  absolute   URL  where  we can be
  612%   contacted.   Before   trying   a     configured    version   through
  613%   http_public_url/2, we try to see wether the login message contains a
  614%   referer parameter or wether the browser provided one.
  615
  616openid_current_url(Request, URL) :-
  617    option(request_uri(URI), Request),
  618    uri_components(URI, Components),
  619    uri_data(path, Components, Path),
  620    (   uri_data(search, Components, QueryString),
  621        nonvar(QueryString),
  622        uri_query_components(QueryString, Query),
  623        memberchk(referer=Base, Query)
  624    ->  true
  625    ;   option(referer(Base), Request)
  626    ), !,
  627    uri_normalized(Path, Base, URL).
  628openid_current_url(Request, URL) :-
  629    http_public_url(Request, URL).
  630
  631%!  openid_current_host(Request, Host, Port)
  632%
  633%   Find current location of the server.
  634%
  635%   @deprecated     New code should use http_current_host/4 with the
  636%                   option global(true).
  637
  638openid_current_host(Request, Host, Port) :-
  639    http_current_host(Request, Host, Port,
  640                      [ global(true)
  641                      ]).
  642
  643
  644%!  redirect_browser(+URL, +FormExtra)
  645%
  646%   Generate a 302 temporary redirect to  URL, adding the extra form
  647%   information from FormExtra. The specs says   we  must retain the
  648%   search specification already attached to the URL.
  649
  650redirect_browser(URL, FormExtra) :-
  651    uri_components(URL, C0),
  652    uri_data(search, C0, Search0),
  653    (   var(Search0)
  654    ->  uri_query_components(Search, FormExtra)
  655    ;   uri_query_components(Search0, Form0),
  656        append(FormExtra, Form0, Form),
  657        uri_query_components(Search, Form)
  658    ),
  659    uri_data(search, C0, Search, C),
  660    uri_components(Redirect, C),
  661    throw(http_reply(moved_temporary(Redirect))).
  662
  663
  664                 /*******************************
  665                 *             RESOLVE          *
  666                 *******************************/
  667
  668%!  openid_resolve(+URL, -OpenIDOrig, -OpenID, -Server, -ServerOptions)
  669%
  670%   True if OpenID is the claimed  OpenID   that  belongs to URL and
  671%   Server is the URL of the  OpenID   server  that  can be asked to
  672%   verify this claim.
  673%
  674%   @param  URL The OpenID typed by the user
  675%   @param  OpenIDOrig Canonized OpenID typed by user
  676%   @param  OpenID Possibly delegated OpenID
  677%   @param  Server OpenID server that must validate OpenID
  678%   @param  ServerOptions provides additional XRDS information about
  679%           the server.  Currently supports xrds_types(Types).
  680%   @tbd    Implement complete URL canonization as defined by the
  681%           OpenID 2.0 proposal.
  682
  683openid_resolve(URL, OpenID, OpenID, Server, [xrds_types(Types)]) :-
  684    xrds_dom(URL, DOM),
  685    xpath(DOM, //(_:'Service'), Service),
  686    findall(Type, xpath(Service, _:'Type'(text), Type), Types),
  687    memberchk('http://specs.openid.net/auth/2.0/server', Types),
  688    xpath(Service, _:'URI'(text), Server),
  689    !,
  690    debug(openid(yadis), 'Yadis: server: ~q, types: ~q', [Server, Types]),
  691    (   xpath(Service, _:'LocalID'(text), OpenID)
  692    ->  true
  693    ;   openid_identifier_select_url(OpenID)
  694    ).
  695openid_resolve(URL, OpenID0, OpenID, Server, []) :-
  696    debug(openid(resolve), 'Opening ~w ...', [URL]),
  697    dtd(html, DTD),
  698    setup_call_cleanup(
  699        http_open(URL, Stream,
  700                  [ final_url(OpenID0),
  701                    cert_verify_hook(ssl_verify)
  702                  ]),
  703        load_structure(Stream, Term,
  704                       [ dtd(DTD),
  705                         dialect(sgml),
  706                         shorttag(false),
  707                         syntax_errors(quiet)
  708                       ]),
  709        close(Stream)),
  710    debug(openid(resolve), 'Scanning HTML document ...', []),
  711    contains_term(element(head, _, Head), Term),
  712    (   link(Head, 'openid.server', Server)
  713    ->  debug(openid(resolve), 'OpenID Server=~q', [Server])
  714    ;   debug(openid(resolve), 'No server in ~q', [Head]),
  715        fail
  716    ),
  717    (   link(Head, 'openid.delegate', OpenID)
  718    ->  debug(openid(resolve), 'OpenID = ~q (delegated)', [OpenID])
  719    ;   OpenID = OpenID0,
  720        debug(openid(resolve), 'OpenID = ~q', [OpenID])
  721    ).
  722
  723openid_identifier_select_url(
  724    'http://specs.openid.net/auth/2.0/identifier_select').
  725
  726:- public ssl_verify/5.  727
  728%!  ssl_verify(+SSL, +ProblemCert, +AllCerts, +FirstCert, +Error)
  729%
  730%   Accept all certificates. We do not care  too much. Only the user
  731%   cares s/he is not entering her  credentials with a spoofed side.
  732%   As we redirect, the browser will take care of this.
  733
  734ssl_verify(_SSL,
  735           _ProblemCertificate, _AllCertificates, _FirstCertificate,
  736           _Error).
  737
  738
  739link(DOM, Type, Target) :-
  740    sub_term(element(link, Attrs, []), DOM),
  741    memberchk(rel=Type, Attrs),
  742    memberchk(href=Target, Attrs).
  743
  744
  745                 /*******************************
  746                 *         AUTHENTICATE         *
  747                 *******************************/
  748
  749%!  openid_authenticate(+Request)
  750%
  751%   HTTP handler when redirected back from the OpenID provider.
  752
  753openid_authenticate(Request) :-
  754    memberchk(accept(Accept), Request),
  755    Accept = [media(application/'xrds+xml',_,_,_)],
  756    !,
  757    http_link_to_id(openid_xrds, [], XRDSLocation),
  758    http_absolute_uri(XRDSLocation, XRDSServer),
  759    debug(openid(yadis), 'Sending XRDS server: ~q', [XRDSServer]),
  760    format('X-XRDS-Location: ~w\n', [XRDSServer]),
  761    format('Content-type: text/plain\n\n').
  762openid_authenticate(Request) :-
  763    openid_authenticate(Request, _OpenIdServer, OpenID, _ReturnTo),
  764    openid_server(User, OpenID, _, Target),
  765    openid_login(User),
  766    redirect_browser(Target, []).
  767
  768
  769%!  openid_authenticate(+Request, -Server:url, -OpenID:url,
  770%!                      -ReturnTo:url) is semidet.
  771%
  772%   Succeeds if Request comes from the   OpenID  server and confirms
  773%   that User is a verified OpenID   user. ReturnTo provides the URL
  774%   to return to.
  775%
  776%   After openid_verify/2 has redirected the   browser to the OpenID
  777%   server, and the OpenID server did   its  magic, it redirects the
  778%   browser back to this address.  The   work  is fairly trivial. If
  779%   =mode= is =cancel=, the OpenId server   denied. If =id_res=, the
  780%   OpenId server replied positive, but  we   must  verify  what the
  781%   server told us by checking the HMAC-SHA signature.
  782%
  783%   This call fails silently if their is no =|openid.mode|= field in
  784%   the request.
  785%
  786%   @throws openid(cancel)
  787%           if request was cancelled by the OpenId server
  788%   @throws openid(signature_mismatch)
  789%           if the HMAC signature check failed
  790
  791openid_authenticate(Request, OpenIdServer, Identity, ReturnTo) :-
  792    memberchk(method(get), Request),
  793    http_parameters(Request,
  794                    [ 'openid.mode'(Mode, [optional(true)])
  795                    ]),
  796    (   var(Mode)
  797    ->  fail
  798    ;   Mode == cancel
  799    ->  throw(openid(cancel))
  800    ;   Mode == id_res
  801    ->  debug(openid(authenticate), 'Mode=id_res, validating response', []),
  802        http_parameters(Request,
  803                        [ 'openid.identity'(Identity, []),
  804                          'openid.assoc_handle'(Handle, []),
  805                          'openid.return_to'(ReturnTo, []),
  806                          'openid.signed'(AtomFields, []),
  807                          'openid.sig'(Base64Signature, []),
  808                          'openid.invalidate_handle'(Invalidate,
  809                                                     [optional(true)])
  810                        ],
  811                        [ form_data(Form)
  812                        ]),
  813        atomic_list_concat(SignedFields, ',', AtomFields),
  814        check_obligatory_fields(SignedFields),
  815        signed_pairs(SignedFields,
  816                     [ mode-Mode,
  817                       identity-Identity,
  818                       assoc_handle-Handle,
  819                       return_to-ReturnTo,
  820                       invalidate_handle-Invalidate
  821                     ],
  822                     Form,
  823                     SignedPairs),
  824        (   openid_associate(OpenIdServer, Handle, Assoc)
  825        ->  signature(SignedPairs, Assoc, Sig),
  826            atom_codes(Base64Signature, Base64SigCodes),
  827            phrase(base64(Signature), Base64SigCodes),
  828            (   Sig == Signature
  829            ->  true
  830            ;   throw(openid(signature_mismatch))
  831            )
  832        ;   check_authentication(Request, Form)
  833        ),
  834        ax_store(Form)
  835    ).
  836
  837%!  signed_pairs(+FieldNames, +Pairs:list(Field-Value),
  838%!               +Form, -SignedPairs) is det.
  839%
  840%   Extract the signed field in the order they appear in FieldNames.
  841
  842signed_pairs([], _, _, []).
  843signed_pairs([Field|T0], Pairs, Form, [Field-Value|T]) :-
  844    memberchk(Field-Value, Pairs),
  845    !,
  846    signed_pairs(T0, Pairs, Form, T).
  847signed_pairs([Field|T0], Pairs, Form, [Field-Value|T]) :-
  848    atom_concat('openid.', Field, OpenIdField),
  849    memberchk(OpenIdField=Value, Form),
  850    !,
  851    signed_pairs(T0, Pairs, Form, T).
  852signed_pairs([Field|T0], Pairs, Form, T) :-
  853    format(user_error, 'Form = ~p~n', [Form]),
  854    throw(error(existence_error(field, Field),
  855                context(_, 'OpenID Signed field is not present'))),
  856    signed_pairs(T0, Pairs, Form, T).
  857
  858
  859%!  check_obligatory_fields(+SignedFields:list) is det.
  860%
  861%   Verify fields from obligatory_field/1 are   in  the signed field
  862%   list.
  863%
  864%   @error  existence_error(field, Field)
  865
  866check_obligatory_fields(Fields) :-
  867    (   obligatory_field(Field),
  868        (   memberchk(Field, Fields)
  869        ->  true
  870        ;   throw(error(existence_error(field, Field),
  871                        context(_, 'OpenID field is not in signed fields')))
  872        ),
  873        fail
  874    ;   true
  875    ).
  876
  877obligatory_field(identity).
  878
  879
  880%!  check_authentication(+Request, +Form) is semidet.
  881%
  882%   Implement the stateless verification method.   This seems needed
  883%   for stackexchange.com, which provides the   =res_id=  with a new
  884%   association handle.
  885
  886check_authentication(_Request, Form) :-
  887    openid_server(_OpenIDLogin, _OpenID, Server),
  888    debug(openid(check_authentication),
  889          'Using stateless verification with ~q form~n~q', [Server, Form]),
  890    select('openid.mode' = _, Form, Form1),
  891    setup_call_cleanup(
  892        http_open(Server, In,
  893                  [ post(form([ 'openid.mode' = check_authentication
  894                              | Form1
  895                              ])),
  896                    cert_verify_hook(ssl_verify)
  897                  ]),
  898        read_stream_to_codes(In, Reply),
  899        close(In)),
  900    debug(openid(check_authentication),
  901          'Reply: ~n~s~n', [Reply]),
  902    key_values_data(Pairs, Reply),
  903    forall(member(invalidate_handle-Handle, Pairs),
  904           retractall(association(_, Handle, _))),
  905    memberchk(is_valid-true, Pairs).
  906
  907
  908                 /*******************************
  909                 *          AX HANDLING         *
  910                 *******************************/
  911
  912%!  ax_options(+ServerOptions, +Options, +AXAttrs) is det.
  913%
  914%   True when AXAttrs is a  list   of  additional attribute exchange
  915%   options to add to the OpenID redirect request.
  916
  917ax_options(ServerOptions, Options, AXAttrs) :-
  918    option(ax(Spec), Options),
  919    option(xrds_types(Types), ServerOptions),
  920    memberchk('http://openid.net/srv/ax/1.0', Types),
  921    !,
  922    http_ax_attributes(Spec, AXAttrs),
  923    debug(openid(ax), 'AX attributes: ~q', [AXAttrs]).
  924ax_options(_, _, []) :-
  925    debug(openid(ax), 'AX: not supported', []).
  926
  927%!  ax_store(+Form)
  928%
  929%   Extract reported AX data and  store   this  into the session. If
  930%   there is a non-empty list of exchanged values, this calls
  931%
  932%       openid_hook(ax(Values))
  933%
  934%   If this hook fails, Values are added   to the session data using
  935%   http_session_assert(ax(Values)).
  936
  937ax_store(Form) :-
  938    debug(openid(ax), 'Form: ~q', [Form]),
  939    ax_form_attributes(Form, Values),
  940    debug(openid(ax), 'AX: ~q', [Values]),
  941    (   Values \== []
  942    ->  (   openid_hook(ax(Values))
  943        ->  true
  944        ;   http_session_assert(ax(Values))
  945        )
  946    ;   true
  947    ).
  948
  949
  950                 /*******************************
  951                 *         OPENID SERVER        *
  952                 *******************************/
  953
  954:- dynamic
  955    server_association/3.           % URL, Handle, Term
  956
  957%!  openid_server(+Options, +Request)
  958%
  959%   Realise the OpenID server. The protocol   demands a POST request
  960%   here.
  961
  962openid_server(Options, Request) :-
  963    http_parameters(Request,
  964                    [ 'openid.mode'(Mode)
  965                    ],
  966                    [ attribute_declarations(openid_attribute),
  967                      form_data(Form)
  968                    ]),
  969    (   Mode == associate
  970    ->  associate_server(Request, Form, Options)
  971    ;   Mode == checkid_setup
  972    ->  checkid_setup_server(Request, Form, Options)
  973    ).
  974
  975%!  associate_server(+Request, +Form, +Options)
  976%
  977%   Handle the association-request. If successful,   create a clause
  978%   for server_association/3 to record the current association.
  979
  980associate_server(Request, Form, Options) :-
  981    memberchk('openid.assoc_type'         = AssocType,   Form),
  982    memberchk('openid.session_type'       = SessionType, Form),
  983    memberchk('openid.dh_modulus'         = P64,         Form),
  984    memberchk('openid.dh_gen'             = G64,         Form),
  985    memberchk('openid.dh_consumer_public' = CPX64,       Form),
  986    base64_btwoc(P, P64),
  987    base64_btwoc(G, G64),
  988    base64_btwoc(CPX, CPX64),
  989    Y is 1+random(P-1),             % Our secret
  990    DiffieHellman is powm(CPX, Y, P),
  991    btwoc(DiffieHellman, DHBytes),
  992    signature_algorithm(SessionType, SHA_Algo),
  993    sha_hash(DHBytes, SHA1, [encoding(octet), algorithm(SHA_Algo)]),
  994    CPY is powm(G, Y, P),
  995    base64_btwoc(CPY, CPY64),
  996    mackey_bytes(SessionType, MacBytes),
  997    new_assoc_handle(MacBytes, Handle),
  998    random_bytes(MacBytes, MacKey),
  999    xor_codes(MacKey, SHA1, EncKey),
 1000    phrase(base64(EncKey), Base64EncKey),
 1001    DefExpriresIn is 24*3600,
 1002    option(expires_in(ExpriresIn), Options, DefExpriresIn),
 1003
 1004    get_time(Now),
 1005    ExpiresAt is integer(Now+ExpriresIn),
 1006    make_association([ session_type(SessionType),
 1007                       expires_at(ExpiresAt),
 1008                       mac_key(MacKey)
 1009                     ],
 1010                     Record),
 1011    memberchk(peer(Peer), Request),
 1012    assert(server_association(Peer, Handle, Record)),
 1013
 1014    key_values_data([ assoc_type-AssocType,
 1015                      assoc_handle-Handle,
 1016                      expires_in-ExpriresIn,
 1017                      session_type-SessionType,
 1018                      dh_server_public-CPY64,
 1019                      enc_mac_key-Base64EncKey
 1020                    ],
 1021                    Text),
 1022    format('Content-type: text/plain~n~n~s', [Text]).
 1023
 1024mackey_bytes('DH-SHA1',   20).
 1025mackey_bytes('DH-SHA256', 32).
 1026
 1027new_assoc_handle(Length, Handle) :-
 1028    random_bytes(Length, Bytes),
 1029    phrase(base64(Bytes), HandleCodes),
 1030    atom_codes(Handle, HandleCodes).
 1031
 1032
 1033%!  checkid_setup_server(+Request, +Form, +Options)
 1034%
 1035%   Validate an OpenID for a TrustRoot and redirect the browser back
 1036%   to the ReturnTo argument.  There   are  many  possible scenarios
 1037%   here:
 1038%
 1039%           1. Check some cookie and if present, grant immediately
 1040%           2. Use a 401 challenge page
 1041%           3. Present a normal grant/password page
 1042%           4. As (3), but use HTTPS for the exchange
 1043%           5. etc.
 1044%
 1045%   First thing to check is the immediate acknowledgement.
 1046
 1047checkid_setup_server(_Request, Form, _Options) :-
 1048    memberchk('openid.identity'       = Identity,  Form),
 1049    memberchk('openid.assoc_handle'   = Handle,    Form),
 1050    memberchk('openid.return_to'      = ReturnTo,  Form),
 1051    (   memberchk('openid.realm'      = Realm,     Form) -> true
 1052    ;   memberchk('openid.trust_root' = Realm, Form)
 1053    ),
 1054
 1055    server_association(_, Handle, _Association),            % check
 1056
 1057    reply_html_page(
 1058        [ title('OpenID login')
 1059        ],
 1060        [ \openid_title,
 1061          div(class('openid-message'),
 1062              ['Site ', a(href(TrustRoot), TrustRoot),
 1063               ' requests permission to login with OpenID ',
 1064               a(href(Identity), Identity), '.'
 1065              ]),
 1066          table(class('openid-form'),
 1067                [ tr(td(form([ action(grant), method('GET') ],
 1068                             [ \hidden('openid.grant', yes),
 1069                               \hidden('openid.identity', Identity),
 1070                               \hidden('openid.assoc_handle', Handle),
 1071                               \hidden('openid.return_to', ReturnTo),
 1072                               \hidden('openid.realm', Realm),
 1073                               \hidden('openid.trust_root', Realm),
 1074                               div(['Password: ',
 1075                                    input([ type(password),
 1076                                            name('openid.password')
 1077                                          ]),
 1078                                    input([ type(submit),
 1079                                            value('Grant')
 1080                                          ])
 1081                                   ])
 1082                             ]))),
 1083                  tr(td(align(right),
 1084                        form([ action(grant), method('GET') ],
 1085                             [ \hidden('openid.grant', no),
 1086                               \hidden('openid.return_to', ReturnTo),
 1087                               input([type(submit), value('Deny')])
 1088                             ])))
 1089                ])
 1090        ]).
 1091
 1092hidden(Name, Value) -->
 1093    html(input([type(hidden), id(return_to), name(Name), value(Value)])).
 1094
 1095
 1096openid_title -->
 1097    { http_absolute_location(icons('openid-logo-square.png'), SRC, []) },
 1098    html_requires(css('openid.css')),
 1099    html(div(class('openid-title'),
 1100             [ a(href('http://openid.net/'),
 1101                 img([ src(SRC), alt('OpenID') ])),
 1102               span('Login')
 1103             ])).
 1104
 1105
 1106%!  openid_grant(+Request)
 1107%
 1108%   Handle the reply from checkid_setup_server/3.   If  the reply is
 1109%   =yes=, check the authority (typically the   password) and if all
 1110%   looks good redirect the browser to   ReturnTo, adding the OpenID
 1111%   properties needed by the Relying Party to verify the login.
 1112
 1113openid_grant(Request) :-
 1114    http_parameters(Request,
 1115                    [ 'openid.grant'(Grant),
 1116                      'openid.return_to'(ReturnTo)
 1117                    ],
 1118                    [ attribute_declarations(openid_attribute)
 1119                    ]),
 1120    (   Grant == yes
 1121    ->  http_parameters(Request,
 1122                        [ 'openid.identity'(Identity),
 1123                          'openid.assoc_handle'(Handle),
 1124                          'openid.trust_root'(TrustRoot),
 1125                          'openid.password'(Password)
 1126                        ],
 1127                        [ attribute_declarations(openid_attribute)
 1128                        ]),
 1129        server_association(_, Handle, Association),
 1130        grant_login(Request,
 1131                    [ identity(Identity),
 1132                      password(Password),
 1133                      trustroot(TrustRoot)
 1134                    ]),
 1135        SignedPairs = [ 'mode'-id_res,
 1136                        'identity'-Identity,
 1137                        'assoc_handle'-Handle,
 1138                        'return_to'-ReturnTo
 1139                      ],
 1140        signed_fields(SignedPairs, Signed),
 1141        signature(SignedPairs, Association, Signature),
 1142        phrase(base64(Signature), Bas64SigCodes),
 1143        string_codes(Bas64Sig, Bas64SigCodes),
 1144        redirect_browser(ReturnTo,
 1145                         [ 'openid.mode' = id_res,
 1146                           'openid.identity' = Identity,
 1147                           'openid.assoc_handle' = Handle,
 1148                           'openid.return_to' = ReturnTo,
 1149                           'openid.signed' = Signed,
 1150                           'openid.sig' = Bas64Sig
 1151                         ])
 1152    ;   redirect_browser(ReturnTo,
 1153                         [ 'openid.mode' = cancel
 1154                         ])
 1155    ).
 1156
 1157
 1158%!  grant_login(+Request, +Options) is det.
 1159%
 1160%   Validate login from Request (can  be   used  to get cookies) and
 1161%   Options, which contains at least:
 1162%
 1163%           * identity(Identity)
 1164%           * password(Password)
 1165%           * trustroot(TrustRoot)
 1166
 1167grant_login(Request, Options) :-
 1168    openid_hook(grant(Request, Options)).
 1169
 1170%!  trusted(+OpenID, +Server)
 1171%
 1172%   True if we  trust  the  given   OpenID  server.  Must  throw  an
 1173%   exception, possibly redirecting to a   page with trusted servers
 1174%   if the given server is not trusted.
 1175
 1176trusted(OpenID, Server) :-
 1177    openid_hook(trusted(OpenID, Server)).
 1178
 1179
 1180%!  signed_fields(+Pairs, -Signed) is det.
 1181%
 1182%   Create a comma-separated  atom  from   the  field-names  without
 1183%   'openid.' from Pairs.
 1184
 1185signed_fields(Pairs, Signed) :-
 1186    signed_field_names(Pairs, Names),
 1187    atomic_list_concat(Names, ',', Signed).
 1188
 1189signed_field_names([], []).
 1190signed_field_names([H0-_|T0], [H|T]) :-
 1191    (   atom_concat('openid.', H, H0)
 1192    ->  true
 1193    ;   H = H0
 1194    ),
 1195    signed_field_names(T0, T).
 1196
 1197%!  signature(+Pairs, +Association, -Signature)
 1198%
 1199%   Determine the signature for Pairs
 1200
 1201signature(Pairs, Association, Signature) :-
 1202    key_values_data(Pairs, TokenContents),
 1203    association_mac_key(Association, MacKey),
 1204    association_session_type(Association, SessionType),
 1205    signature_algorithm(SessionType, SHA),
 1206    hmac_sha(MacKey, TokenContents, Signature, [algorithm(SHA)]),
 1207    debug(openid(crypt),
 1208          'Signed:~n~s~nSignature: ~w', [TokenContents, Signature]).
 1209
 1210signature_algorithm('DH-SHA1',   sha1).
 1211signature_algorithm('DH-SHA256', sha256).
 1212
 1213
 1214                 /*******************************
 1215                 *            ASSOCIATE         *
 1216                 *******************************/
 1217
 1218:- dynamic
 1219    association/3.                  % URL, Handle, Data
 1220
 1221:- record
 1222    association(session_type='DH-SHA1',
 1223                expires_at,         % time-stamp
 1224                mac_key).           % code-list
 1225
 1226%!  openid_associate(?URL, ?Handle, ?Assoc) is det.
 1227%
 1228%   Calls openid_associate/4 as
 1229%
 1230%       ==
 1231%       openid_associate(URL, Handle, Assoc, []).
 1232%       ==
 1233
 1234openid_associate(URL, Handle, Assoc) :-
 1235    openid_associate(URL, Handle, Assoc, []).
 1236
 1237%!  openid_associate(+URL, -Handle, -Assoc, +Options) is det.
 1238%!  openid_associate(?URL, +Handle, -Assoc, +Options) is semidet.
 1239%
 1240%   Associate with an open-id server.  We   first  check for a still
 1241%   valid old association. If there is  none   or  it is expired, we
 1242%   esstablish one and remember it.  Options:
 1243%
 1244%     * ns(URL)
 1245%     One of =http://specs.openid.net/auth/2.0= (default) or
 1246%     =http://openid.net/signon/1.1=.
 1247%
 1248%   @tbd    Should we store known associations permanently?  Where?
 1249
 1250openid_associate(URL, Handle, Assoc, _Options) :-
 1251    nonvar(Handle),
 1252    !,
 1253    debug(openid(associate),
 1254          'OpenID: Lookup association with handle ~q', [Handle]),
 1255    (   association(URL, Handle, Assoc)
 1256    ->  true
 1257    ;   debug(openid(associate),
 1258              'OpenID: no association with handle ~q', [Handle]),
 1259        fail
 1260    ).
 1261openid_associate(URL, Handle, Assoc, _Options) :-
 1262    must_be(atom, URL),
 1263    association(URL, Handle, Assoc),
 1264    association_expires_at(Assoc, Expires),
 1265    get_time(Now),
 1266    (   Now < Expires
 1267    ->  !,
 1268        debug(openid(associate),
 1269              'OpenID: Reusing association with ~q', [URL])
 1270    ;   retractall(association(URL, Handle, _)),
 1271        fail
 1272    ).
 1273openid_associate(URL, Handle, Assoc, Options) :-
 1274    associate_data(Data, P, _G, X, Options),
 1275    debug(openid(associate), 'OpenID: Associating with ~q', [URL]),
 1276    setup_call_cleanup(
 1277        http_open(URL, In,
 1278                  [ post(form(Data)),
 1279                    cert_verify_hook(ssl_verify)
 1280                  ]),
 1281        read_stream_to_codes(In, Reply),
 1282        close(In)),
 1283    debug(openid(associate), 'Reply: ~n~s', [Reply]),
 1284    key_values_data(Pairs, Reply),
 1285    shared_secret(Pairs, P, X, MacKey),
 1286    expires_at(Pairs, ExpiresAt),
 1287    memberchk(assoc_handle-Handle, Pairs),
 1288    memberchk(session_type-Type, Pairs),
 1289    make_association([ session_type(Type),
 1290                       expires_at(ExpiresAt),
 1291                       mac_key(MacKey)
 1292                     ], Assoc),
 1293    assert(association(URL, Handle, Assoc)).
 1294
 1295
 1296%!  shared_secret(+Pairs, +P, +X, -Secret:list(codes))
 1297%
 1298%   Find the shared secret from the peer's reply and our data. First
 1299%   clause deals with the (deprecated) non-encoded version.
 1300
 1301shared_secret(Pairs, _, _, Secret) :-
 1302    memberchk(mac_key-Base64, Pairs),
 1303    !,
 1304    atom_codes(Base64, Base64Codes),
 1305    phrase(base64(Base64Codes), Secret).
 1306shared_secret(Pairs, P, X, Secret) :-
 1307    memberchk(dh_server_public-Base64Public, Pairs),
 1308    memberchk(enc_mac_key-Base64EncMacKey, Pairs),
 1309    memberchk(session_type-SessionType, Pairs),
 1310    base64_btwoc(ServerPublic, Base64Public),
 1311    DiffieHellman is powm(ServerPublic, X, P),
 1312    atom_codes(Base64EncMacKey, Base64EncMacKeyCodes),
 1313    phrase(base64(EncMacKey), Base64EncMacKeyCodes),
 1314    btwoc(DiffieHellman, DiffieHellmanBytes),
 1315    signature_algorithm(SessionType, SHA_Algo),
 1316    sha_hash(DiffieHellmanBytes, DHHash,
 1317             [encoding(octet), algorithm(SHA_Algo)]),
 1318    xor_codes(DHHash, EncMacKey, Secret).
 1319
 1320
 1321%!  expires_at(+Pairs, -Time) is det.
 1322%
 1323%   Unify Time with  a  time-stamp   stating  when  the  association
 1324%   exires.
 1325
 1326expires_at(Pairs, Time) :-
 1327    memberchk(expires_in-ExpAtom, Pairs),
 1328    atom_number(ExpAtom, Seconds),
 1329    get_time(Now),
 1330    Time is integer(Now)+Seconds.
 1331
 1332
 1333%!  associate_data(-Data, -P, -G, -X, +Options) is det.
 1334%
 1335%   Generate the data to initiate an association using Diffie-Hellman
 1336%   shared secret key negotiation.
 1337
 1338associate_data(Data, P, G, X, Options) :-
 1339    openid_dh_p(P),
 1340    openid_dh_g(G),
 1341    X is 1+random(P-1),                     % 1<=X<P-1
 1342    CP is powm(G, X, P),
 1343    base64_btwoc(P, P64),
 1344    base64_btwoc(G, G64),
 1345    base64_btwoc(CP, CP64),
 1346    option(ns(NS), Options, 'http://specs.openid.net/auth/2.0'),
 1347    (   assoc_type(NS, DefAssocType, DefSessionType)
 1348    ->  true
 1349    ;   domain_error('openid.ns', NS)
 1350    ),
 1351    option(assoc_type(AssocType), Options, DefAssocType),
 1352    option(assoc_type(SessionType), Options, DefSessionType),
 1353    Data = [ 'openid.ns'                 = NS,
 1354             'openid.mode'               = associate,
 1355             'openid.assoc_type'         = AssocType,
 1356             'openid.session_type'       = SessionType,
 1357             'openid.dh_modulus'         = P64,
 1358             'openid.dh_gen'             = G64,
 1359             'openid.dh_consumer_public' = CP64
 1360           ].
 1361
 1362assoc_type('http://specs.openid.net/auth/2.0',
 1363           'HMAC-SHA256',
 1364           'DH-SHA256').
 1365assoc_type('http://openid.net/signon/1.1',
 1366           'HMAC-SHA1',
 1367           'DH-SHA1').
 1368
 1369
 1370                 /*******************************
 1371                 *            RANDOM            *
 1372                 *******************************/
 1373
 1374%!  random_bytes(+N, -Bytes) is det.
 1375%
 1376%   Bytes is a list of N random bytes (integers 0..255).
 1377
 1378random_bytes(N, [H|T]) :-
 1379    N > 0,
 1380    !,
 1381    H is random(256),
 1382    N2 is N - 1,
 1383    random_bytes(N2, T).
 1384random_bytes(_, []).
 1385
 1386
 1387                 /*******************************
 1388                 *           CONSTANTS          *
 1389                 *******************************/
 1390
 1391openid_dh_p(155172898181473697471232257763715539915724801966915404479707795314057629378541917580651227423698188993727816152646631438561595825688188889951272158842675419950341258706556549803580104870537681476726513255747040765857479291291572334510643245094715007229621094194349783925984760375594985848253359305585439638443).
 1392
 1393openid_dh_g(2).
 1394
 1395
 1396                 /*******************************
 1397                 *             UTIL             *
 1398                 *******************************/
 1399
 1400%!  key_values_data(+KeyValues:list(Key-Value), -Data:list(code)) is det.
 1401%!  key_values_data(-KeyValues:list(Key-Value), +Data:list(code)) is det.
 1402%
 1403%   Encoding  and  decoding  of  key-value  pairs  for  OpenID  POST
 1404%   messages  according  to   Appendix   C    of   the   OpenID  1.1
 1405%   specification.
 1406
 1407key_values_data(Pairs, Data) :-
 1408    nonvar(Data),
 1409    !,
 1410    phrase(data_form(Pairs), Data).
 1411key_values_data(Pairs, Data) :-
 1412    phrase(gen_data_form(Pairs), Data).
 1413
 1414data_form([Key-Value|Pairs]) -->
 1415    utf8_string(KeyCodes), ":", utf8_string(ValueCodes), "\n",
 1416    !,
 1417    { atom_codes(Key, KeyCodes),
 1418      atom_codes(Value, ValueCodes)
 1419    },
 1420    data_form(Pairs).
 1421data_form([]) -->
 1422    ws.
 1423
 1424%!  utf8_string(-Codes)// is nondet.
 1425%
 1426%   Take a short UTF-8 code-list from input. Extend on backtracking.
 1427
 1428utf8_string([]) -->
 1429    [].
 1430utf8_string([H|T]) -->
 1431    utf8_codes([H]),
 1432    utf8_string(T).
 1433
 1434ws -->
 1435    [C],
 1436    { C =< 32 },
 1437    !,
 1438    ws.
 1439ws -->
 1440    [].
 1441
 1442
 1443gen_data_form([]) -->
 1444    [].
 1445gen_data_form([Key-Value|T]) -->
 1446    field(Key), ":", field(Value), "\n",
 1447    gen_data_form(T).
 1448
 1449field(Field) -->
 1450    { to_codes(Field, Codes)
 1451    },
 1452    utf8_codes(Codes).
 1453
 1454to_codes(Codes, Codes) :-
 1455    is_list(Codes),
 1456    !.
 1457to_codes(Atomic, Codes) :-
 1458    atom_codes(Atomic, Codes).
 1459
 1460%!  base64_btwoc(+Int, -Base64:list(code)) is det.
 1461%!  base64_btwoc(-Int, +Base64:list(code)) is det.
 1462%!  base64_btwoc(-Int, +Base64:atom) is det.
 1463
 1464base64_btwoc(Int, Base64) :-
 1465    integer(Int),
 1466    !,
 1467    btwoc(Int, Bytes),
 1468    phrase(base64(Bytes), Base64).
 1469base64_btwoc(Int, Base64) :-
 1470    atom(Base64),
 1471    !,
 1472    atom_codes(Base64, Codes),
 1473    phrase(base64(Bytes), Codes),
 1474    btwoc(Int, Bytes).
 1475base64_btwoc(Int, Base64) :-
 1476    phrase(base64(Bytes), Base64),
 1477    btwoc(Int, Bytes).
 1478
 1479
 1480%!  btwoc(+Integer, -Bytes) is det.
 1481%!  btwoc(-Integer, +Bytes) is det.
 1482%
 1483%   Translate between a big integer and and its representation in
 1484%   bytes.  The first bit is always 0, as Integer is nonneg.
 1485
 1486btwoc(Int, Bytes) :-
 1487    integer(Int),
 1488    !,
 1489    int_to_bytes(Int, Bytes).
 1490btwoc(Int, Bytes) :-
 1491    is_list(Bytes),
 1492    bytes_to_int(Bytes, Int).
 1493
 1494int_to_bytes(Int, Bytes) :-
 1495    int_to_bytes(Int, [], Bytes).
 1496
 1497int_to_bytes(Int, Bytes0, [Int|Bytes0]) :-
 1498    Int < 128,
 1499    !.
 1500int_to_bytes(Int, Bytes0, Bytes) :-
 1501    Last is Int /\ 0xff,
 1502    Int1 is Int >> 8,
 1503    int_to_bytes(Int1, [Last|Bytes0], Bytes).
 1504
 1505
 1506bytes_to_int([B|T], Int) :-
 1507    bytes_to_int(T, B, Int).
 1508
 1509bytes_to_int([], Int, Int).
 1510bytes_to_int([B|T], Int0, Int) :-
 1511    Int1 is (Int0<<8)+B,
 1512    bytes_to_int(T, Int1, Int).
 1513
 1514
 1515%!  xor_codes(+C1:list(int), +C2:list(int), -XOR:list(int)) is det.
 1516%
 1517%   Compute xor of two strings.
 1518%
 1519%   @error  length_mismatch(L1, L2) if the two lists do not have equal
 1520%           length.
 1521
 1522xor_codes([], [], []) :- !.
 1523xor_codes([H1|T1], [H2|T2], [H|T]) :-
 1524    !,
 1525    H is H1 xor H2,
 1526    !,
 1527    xor_codes(T1, T2, T).
 1528xor_codes(L1, L2, _) :-
 1529    throw(error(length_mismatch(L1, L2), _)).
 1530
 1531
 1532                 /*******************************
 1533                 *        HTTP ATTRIBUTES       *
 1534                 *******************************/
 1535
 1536openid_attribute('openid.mode',
 1537                 [ oneof([ associate,
 1538                           checkid_setup,
 1539                           cancel,
 1540                           id_res
 1541                         ])
 1542                 ]).
 1543openid_attribute('openid.assoc_type',
 1544                 [ oneof(['HMAC-SHA1'])
 1545                 ]).
 1546openid_attribute('openid.session_type',
 1547                 [ oneof([ 'DH-SHA1',
 1548                           'DH-SHA256'
 1549                         ])
 1550                 ]).
 1551openid_attribute('openid.dh_modulus',         [length > 1]).
 1552openid_attribute('openid.dh_gen',             [length > 1]).
 1553openid_attribute('openid.dh_consumer_public', [length > 1]).
 1554openid_attribute('openid.assoc_handle',       [length > 1]).
 1555openid_attribute('openid.return_to',          [length > 1]).
 1556openid_attribute('openid.trust_root',         [length > 1]).
 1557openid_attribute('openid.identity',           [length > 1]).
 1558openid_attribute('openid.password',           [length > 1]).
 1559openid_attribute('openid.grant',              [oneof([yes,no])])