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