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)  2015-2016, VU University Amsterdam
   7    All rights reserved.
   8
   9    Redistribution and use in source and binary forms, with or without
  10    modification, are permitted provided that the following conditions
  11    are met:
  12
  13    1. Redistributions of source code must retain the above copyright
  14       notice, this list of conditions and the following disclaimer.
  15
  16    2. Redistributions in binary form must reproduce the above copyright
  17       notice, this list of conditions and the following disclaimer in
  18       the documentation and/or other materials provided with the
  19       distribution.
  20
  21    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  22    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  23    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
  24    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
  25    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
  26    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
  27    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
  28    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
  29    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
  30    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
  31    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
  32    POSSIBILITY OF SUCH DAMAGE.
  33*/
  34
  35:- module(http_digest,
  36          [ http_digest_challenge//2,      % +Realm, +Options
  37            http_digest_password_hash/4,   % +User, +Realm, +Passwd, -Hash
  38                                           % client support
  39            http_parse_digest_challenge/2, % +Challenge, -Fields
  40            http_digest_response/5         % +Fields, +User, +Password,
  41                                           % -Reply +Opts
  42          ]).
  43:- use_module(library(http/http_authenticate)).
  44:- use_module(library(http/http_stream)).
  45:- use_module(library(dcg/basics)).
  46:- use_module(library(md5)).
  47:- use_module(library(error)).
  48:- use_module(library(option)).
  49:- use_module(library(debug)).
  50:- use_module(library(settings)).
  51:- use_module(library(base64)).
  52:- use_module(library(broadcast)).
  53:- use_module(library(uri)).
  54:- use_module(library(apply)).
  55
  56
  57/** <module> HTTP Digest authentication
  58
  59This library implements HTTP  _Digest   Authentication_  as per RFC2617.
  60Unlike  _Basic  Authentication_,  digest  authentication   is  based  on
  61challenge-reponse and therefore does not need  to send the password over
  62the (insecure) connection. In addition, it   provides  a count mechanism
  63that ensure that old  credentials  cannot   be  reused,  which  prevents
  64attackers  from  using  old  credentials  with  a  new  request.  Digest
  65authentication have the following advantages and disadvantages:
  66
  67  - Advantages
  68    - Authentication without exchanging the password
  69    - No re-use of authentication data
  70  - Disadvantages
  71    - An extra round trip is needed for the first authentication
  72    - Server-side storage of the password is the MD5 hash of the
  73      user, _realm_ and password.  As MD5 hashes are quick to
  74      compute, one needs strong passwords.  This fixed algorithm
  75      also allows for _rainbow table_ attacks, although their
  76      value is limited because you need to precompute the rainbow
  77      table for every server (_realm_) and user.
  78    - The connection is sensitive to man-in-the-middle attack,
  79      where the attacker can both change the request and response.
  80    - Both client and server need to keep an administration of
  81      issued _nonce_ values and associated _nonce count_ values.
  82
  83And, of course, the connection  itself   remains  insecure. Digest based
  84authentication is a viable alternative if HTTPS is not a good option and
  85security of the data itself is not an issue.
  86
  87This library acts as plugin   for library(http/http_dispatch), where the
  88registered handler (http_handler/3) can be  given   the  option below to
  89initiate digest authentication.
  90
  91  - authentication(digest(PasswdFile, Realm))
  92
  93Above, `PasswdFile` is a file containing lines  of the from below, where
  94PasswordHash is computed  using   http_digest_password_hash/4.  See also
  95library(http/http_authenticate),       http_read_passwd_file/2       and
  96http_write_passwd_file/2.
  97
  98  ==
  99  User ":" PasswordHash (":" Extra)*
 100  ==
 101
 102This library also  hooks  into   library(http/http_open)  if  the option
 103authorization(digest(User, Password)) is given.
 104
 105@see https://tools.ietf.org/html/rfc2617
 106*/
 107
 108:- setting(nonce_timeout, number, 3600,
 109           "Validity time for a server nonce").
 110:- setting(client_nonce_timeout, number, 3600,
 111           "Validity time for a client nonce").
 112
 113                 /*******************************
 114                 *      TRACK CONNECTIONS       *
 115                 *******************************/
 116
 117:- dynamic
 118    nonce_key/1,                    % Our nonce private key
 119    nonce/2,                        % Nonce, CreatedTime
 120    nonce_nc/3,                     % Nonce, NC, Time
 121    nonce_nc_first/2,               % Nonce, NC
 122    nonce_gc_time/1.                % Time of last nonce GC
 123
 124%!  register_nonce(+Nonce, +Created) is det.
 125%
 126%   Register a nonce created by the  server.   We  need  to do so to
 127%   ensure the client uses our nonce  and that the connection should
 128%   not considered timed out.
 129
 130register_nonce(Nonce64, Created) :-
 131    broadcast(http_digest(nonce(Nonce64, Created))),
 132    assertz(nonce(Nonce64, Created)),
 133    gc_nonce.
 134
 135%!  nonce_ok(+Nonce, +NC, -Stale) is semidet.
 136%
 137%   True if Nonce at nonce-count NC   is  acceptable. That means the
 138%   nonce has not timed out and we   have not seen the same sequence
 139%   number  before.  Note  that  requests   may  be  concurrent  and
 140%   therefore NC values may not come in order.
 141
 142nonce_ok(Nonce, NC, Stale) :-
 143    get_time(Now),
 144    nonce_not_timed_out(Nonce, Now, Stale),
 145    nonce_nc_ok(Nonce, NC, Now).
 146
 147nonce_not_timed_out(Nonce, Now, Stale) :-
 148    (   nonce(Nonce, Created)
 149    ->  setting(nonce_timeout, TimeOut),
 150        (   Now - Created < TimeOut
 151        ->  Stale = false
 152        ;   forget_nonce(Nonce),
 153            debug(http(nonce), 'Nonce timed out: ~q', [Nonce]),
 154            Stale = true
 155        )
 156    ;   our_nonce(Nonce, _Stamp)
 157    ->  Stale = true
 158    ;   debug(http(nonce), 'Unknown nonce: ~q', [Nonce]),
 159        fail
 160    ).
 161
 162nonce_nc_ok(Nonce, NC, _Now) :-
 163    (   nonce_nc(Nonce, NC, _)
 164    ;   nonce_nc_first(Nonce, First),
 165        NC @=< First
 166    ),
 167    !,
 168    debug(http(nonce), 'Nonce replay attempt: ~q@~q', [Nonce, NC]),
 169    fail.
 170nonce_nc_ok(Nonce, NC, Now) :-
 171    assertz(nonce_nc(Nonce, NC, Now)).
 172
 173forget_nonce(Nonce) :-
 174    retractall(nonce(Nonce, _)),
 175    retractall(nonce_nc(Nonce, _, _)),
 176    retractall(nonce_nc_first(Nonce, _)).
 177
 178%!  gc_nonce
 179%
 180%   Garbage collect server nonce.
 181
 182gc_nonce :-
 183    nonce_gc_time(Last),
 184    get_time(Now),
 185    setting(nonce_timeout, TimeOut),
 186    Now-Last < TimeOut/4,
 187    !.
 188gc_nonce :-
 189    with_mutex(http_digest_gc_nonce,
 190               gc_nonce_sync).
 191
 192gc_nonce_sync :-
 193    get_time(Now),
 194    asserta(nonce_gc_time(Now)),
 195    forall(( nonce_gc_time(T),
 196             T \== Now
 197           ),
 198           retractall(nonce_gc_time(T))),
 199    setting(nonce_timeout, TimeOut),
 200    Before is Now - TimeOut,
 201    forall(nonce_timed_out(Nonce, Before),
 202           forget_nonce(Nonce)),
 203    NCBefore is Now - 60,
 204    forall(nonce(Nonce, _Created),
 205           gc_nonce_nc(Nonce, NCBefore)).
 206
 207nonce_timed_out(Nonce, Before) :-
 208    nonce(Nonce, Created),
 209    Created < Before.
 210
 211gc_nonce_nc(Nonce, Before) :-
 212    findall(NC, gc_nonce_nc(Nonce, Before, NC), List),
 213    sort(0, @>, List, [Max|_]),
 214    !,
 215    asserta(nonce_nc_first(Nonce, Max)),
 216    forall(( nonce_nc_first(Nonce, NC),
 217             NC \== Max
 218           ),
 219           retractall(nonce_nc_first(Nonce, NC))).
 220gc_nonce_nc(_, _).
 221
 222gc_nonce_nc(Nonce, Before, NC) :-
 223    nonce_nc(Nonce, NC, Time),
 224    Time < Before,
 225    retractall(nonce_nc(Nonce, NC, Time)).
 226
 227
 228
 229%!  private_key(-PrivateKey) is det.
 230%
 231%   Return our private key.
 232
 233private_key(PrivateKey) :-
 234    nonce_key(PrivateKey),
 235    !.
 236private_key(PrivateKey) :-
 237    with_mutex(http_digest,
 238               private_key_sync(PrivateKey)).
 239
 240private_key_sync(PrivateKey) :-
 241    nonce_key(PrivateKey),
 242    !.
 243private_key_sync(PrivateKey) :-
 244    PrivateKey is random(1<<63-1),
 245    assertz(nonce_key(PrivateKey)).
 246
 247%!  our_nonce(+Nonce, -Stamp:string) is semidet.
 248%
 249%   True if we created Nonce at time Stamp.
 250%
 251%   @arg  Stamp  is  the  stamp  as  created  by  nonce//1:  a  time
 252%   stamp*1000+sequence number.
 253
 254our_nonce(Nonce64, Stamp) :-
 255    base64(Nonce, Nonce64),
 256    split_string(Nonce, ":", "", [Stamp,HNonceContent]),
 257    private_key(PrivateKey),
 258    atomics_to_string([Stamp,PrivateKey], ":", NonceContent),
 259    hash(NonceContent, HNonceContent).
 260
 261
 262                 /*******************************
 263                 *            GRAMMAR           *
 264                 *******************************/
 265
 266%!  http_digest_challenge(+Realm, +Options)//
 267%
 268%   Generate the content for  a   401  =|WWW-Authenticate:  Digest|=
 269%   header field.
 270
 271http_digest_challenge(Realm, Options) -->
 272    %       "Digest ",
 273            realm(Realm),
 274            domain(Options),
 275            nonce(Options),
 276            option_value(opaque, Options),
 277            stale(Options),
 278    %       algorithm(Options),
 279            qop_options(Options).
 280%       auth_param(Options).
 281
 282realm(Realm) -->
 283    { no_dquote(realm, Realm) },
 284    "realm=\"", atom(Realm), "\"".
 285
 286domain(Options) -->
 287    { option(domain(Domain), Options) },
 288    !,
 289    sep, "domain=\"", uris(Domain), "\"".
 290domain(_) --> "".
 291
 292uris(Domain) -->
 293    { atomic(Domain) },
 294    !,
 295    uri(Domain).
 296uris(Domains) -->
 297    { must_be(list(atomic), Domains)
 298    },
 299    uri_list(Domains).
 300
 301uri_list([]) --> "".
 302uri_list([H|T]) -->
 303    uri(H),
 304    (   {T \== []}
 305    ->  " ", uri_list(T)
 306    ;   ""
 307    ).
 308
 309uri(URI) -->
 310    { no_dquote(uri, URI) },
 311    atom(URI).
 312
 313%!  nonce(+Options)
 314%
 315%   Compute the server _nonce_ value.  Note   that  we  should never
 316%   generate the same nonce twice for   the  same client. The client
 317%   _may_ issue multiple requests without   an  authorization header
 318%   for resources appearing on a page. As long as we return distinct
 319%   nonce values, this is ok. If we do not, the server will reuse NC
 320%   counters on the same nonce, which will break the authentication.
 321
 322nonce(Options) -->
 323    { get_time(Now),
 324      flag(http_digest_nonce_seq, Seq, Seq+1),
 325      Stamp is floor(Now)*1000+(Seq mod 1000),
 326      private_key(PrivateKey),
 327      atomics_to_string([Stamp,PrivateKey], ":", NonceContent),
 328      hash(NonceContent, HNonceContent),
 329      atomics_to_string([Stamp,HNonceContent], ":", NonceText),
 330      base64(NonceText, Nonce),
 331      option(nonce(Nonce-Now), Options, _),
 332      debug(http(authenticate), 'Server nonce: ~q', [Nonce])
 333    },
 334    sep, "nonce=\"", atom(Nonce), "\"".
 335
 336stale(Options) -->
 337    { option(stale(true), Options), !
 338    },
 339    sep, "stale=true".
 340stale(_) --> "".
 341
 342qop_options(_Options) -->
 343    sep, "qop=\"auth,auth-int\"".
 344
 345option_value(Key, Options) -->
 346    { Opt =.. [Key,Value],
 347      option(Opt, Options), !
 348    },
 349    key_qvalue(Key, Value).
 350option_value(_, _) --> "".
 351
 352key_value(Key, Value)  -->
 353    atom(Key), "=", atom(Value).
 354key_qvalue(Key, Value) -->
 355    { no_dquote(Key, Value) },
 356    atom(Key), "=\"", atom(Value), "\"".
 357
 358no_dquote(Key, Value) :-
 359    nonvar(Value),
 360    sub_atom(Value, _, _, _, '"'),
 361    !,
 362    domain_error(Key, value).
 363no_dquote(_, _).
 364
 365sep --> ", ".
 366
 367hash(Text, Hash) :-
 368    md5_hash(Text, Hash, []).
 369
 370%!  http_digest_authenticate(+Request, -User, -UserFields, +Options)
 371%
 372%   Validate the client reponse from the Request header. On success,
 373%   User is the validated user and  UserFields are additional fields
 374%   from the password file. Options include:
 375%
 376%     - passwd_file(+File)
 377%     Validate passwords agains the given password file.  The
 378%     file is read using http_current_user/3 from
 379%     library(http/http_authenticate).
 380%     - stale(-Stale)
 381%     The request may succeed on a timed-out server nonce.  In
 382%     that case, Stale is unified with `true`.
 383
 384http_digest_authenticate(Request, [User|Fields], Options) :-
 385    memberchk(authorization(Authorization), Request),
 386    debug(http(authenticate), 'Authorization: ~w', [Authorization]),
 387    digest_authenticate(Authorization, User, Fields, Options).
 388
 389digest_authenticate(Authorization, User, Fields, Options) :-
 390    string_codes(Authorization, AuthorizationCodes),
 391    phrase(parse_digest_reponse(AuthValues), AuthorizationCodes),
 392    memberchk(username(User), AuthValues),
 393    memberchk(realm(Realm), AuthValues),
 394    memberchk(nonce(ServerNonce), AuthValues),
 395    memberchk(uri(Path), AuthValues),
 396    memberchk(qop(QOP), AuthValues),
 397    memberchk(nc(NC), AuthValues),
 398    memberchk(cnonce(ClientNonce), AuthValues),
 399    memberchk(response(Response), AuthValues),
 400    user_ha1_details(User, Realm, HA1, Fields, Options),
 401    option(method(Method), Options, get),
 402    ha2(Method, Path, HA2),
 403    atomics_to_string([ HA1,
 404                        ServerNonce,
 405                        NC,
 406                        ClientNonce,
 407                        QOP,
 408                        HA2
 409                      ], ":", ResponseText),
 410    debug(http(authenticate), 'ResponseText: ~w', [ResponseText]),
 411    hash(ResponseText, ResponseExpected),
 412    (   Response == ResponseExpected
 413    ->  debug(http(authenticate), 'We have a match!', [])
 414    ;   debug(http(authenticate),
 415              '~q \\== ~q', [Response, ResponseExpected]),
 416        fail
 417    ),
 418    nonce_ok(ServerNonce, NC, Stale),
 419    (   option(stale(Stale), Options)
 420    ->  true
 421    ;   Stale == false
 422    ).
 423
 424user_ha1_details(User, _Realm, HA1, Fields, Options) :-
 425    option(passwd_file(File), Options),
 426    http_current_user(File, User, [HA1|Fields]).
 427
 428%!  parse_digest_request(-Fields)//
 429%
 430%   Parse a digest request into a list of Name(Value) terms.
 431
 432parse_digest_request(Fields) -->
 433    "Digest", whites,
 434    digest_values(Fields).
 435
 436%!  parse_digest_reponse(-ResponseValues)//
 437
 438parse_digest_reponse(ResponseValues) -->
 439    "Digest", whites,
 440    digest_values(ResponseValues).
 441
 442
 443digest_values([H|T]) -->
 444    digest_value(H),
 445    !,
 446    whites,
 447    (   ","
 448    ->  whites,
 449        digest_values(T)
 450    ;   {T = []}
 451    ).
 452
 453digest_value(V) -->
 454    string_without(`=`, NameCodes), "=",
 455    { atom_codes(Name, NameCodes) },
 456    digest_value(Name, V).
 457
 458digest_value(Name, V) -->
 459    "\"",
 460    !,
 461    string_without(`"`, ValueCodes), "\"",
 462    { parse_value(Name, ValueCodes, Value),
 463      V =.. [Name,Value]
 464    }.
 465digest_value(stale, stale(V)) -->
 466    !,
 467    boolean(V).
 468digest_value(Name, V) -->
 469    string_without(`, `, ValueCodes),
 470    { parse_value(Name, ValueCodes, Value),
 471      V =.. [Name,Value]
 472    }.
 473
 474
 475parse_value(domain, Codes, Domain) :-
 476    !,
 477    string_codes(String, Codes),
 478    atomic_list_concat(Domain, ' ', String).
 479parse_value(Name, Codes, Value) :-
 480    atom_value(Name),
 481    atom_codes(Value, Codes).
 482parse_value(_Name, Codes, Value) :-
 483    string_codes(Value, Codes).
 484
 485atom_value(realm).
 486atom_value(username).
 487atom_value(response).
 488atom_value(nonce).
 489atom_value(stale).              % for misbehaving servers that quote stale
 490
 491boolean(true) --> "true".
 492boolean(false) --> "false".
 493
 494
 495                 /*******************************
 496                 *           CLIENT             *
 497                 *******************************/
 498
 499%!  http_parse_digest_challenge(+Challenge, -Fields) is det.
 500%
 501%   Parse the value of an HTTP =|WWW-Authenticate|= header into
 502%   a list of Name(Value) terms.
 503
 504http_parse_digest_challenge(Challenge, Fields) :-
 505    string_codes(Challenge, ReqCodes),
 506    phrase(parse_digest_request(Fields), ReqCodes).
 507
 508%!  http_digest_response(+Challenge, +User, +Password, -Reply, +Options)
 509%
 510%   Formulate a reply to a digest authentication request.  Options:
 511%
 512%     - path(+Path)
 513%     The request URI send along with the authentication.  Defaults
 514%     to `/`
 515%     - method(+Method)
 516%     The HTTP method.  Defaults to `'GET'`
 517%     - nc(+Integer)
 518%     The nonce-count as an integer.  This is formatted as an
 519%     8 hex-digit string.
 520%
 521%   @arg    Challenge is a list Name(Value), normally from
 522%           http_parse_digest_challenge/2.  Must contain
 523%           `realm` and  `nonce`.  Optionally contains
 524%           `opaque`.
 525%   @arg    User is the user we want to authenticated
 526%   @arg    Password is the user's password
 527%   @arg    Options provides additional options
 528
 529http_digest_response(Fields, User, Password, Reply, Options) :-
 530    phrase(http_digest_response(Fields, User, Password, Options), Codes),
 531    string_codes(Reply, Codes).
 532
 533http_digest_response(Fields, User, Password, Options) -->
 534    { memberchk(nonce(ServerNonce), Fields),
 535      memberchk(realm(Realm), Fields),
 536      client_nonce(ClientNonce),
 537      http_digest_password_hash(User, Realm, Password, HA1),
 538      QOP = 'auth',
 539      option(path(Path), Options, /),
 540      option(method(Method), Options, 'GET'),
 541      option(nc(NC), Options, 1),
 542      format(string(NCS), '~`0t~16r~8+', [NC]),
 543      ha2(Method, Path, HA2),
 544      atomics_to_string([ HA1,
 545                          ServerNonce,
 546                          NCS,
 547                          ClientNonce,
 548                          QOP,
 549                          HA2
 550                        ], ":", ResponseText),
 551      hash(ResponseText, Response)
 552    },
 553    "Digest ",
 554    key_qvalue(username, User),
 555    sep, key_qvalue(realm, Realm),
 556    sep, key_qvalue(nonce, ServerNonce),
 557    sep, key_qvalue(uri, Path),
 558    sep, key_value(qop, QOP),
 559    sep, key_value(nc, NCS),
 560    sep, key_qvalue(cnonce, ClientNonce),
 561    sep, key_qvalue(response, Response),
 562    (   { memberchk(opaque(Opaque), Fields) }
 563    ->  sep, key_qvalue(opaque, Opaque)
 564    ;   ""
 565    ).
 566
 567client_nonce(Nonce) :-
 568    V is random(1<<32),
 569    format(string(Nonce), '~`0t~16r~8|', [V]).
 570
 571ha2(Method, Path, HA2) :-
 572    string_upper(Method, UMethod),
 573    atomics_to_string([UMethod,Path], ":", A2),
 574    hash(A2, HA2).
 575
 576%!  http_digest_password_hash(+User, +Realm, +Password, -Hash) is det.
 577%
 578%   Compute the password hash for the HTTP password file.  Note that
 579%   the HTTP digest mechanism does allow us to use a seeded expensive
 580%   arbitrary hash function.  Instead, the hash is defined as the MD5
 581%   of the following components:
 582%
 583%     ==
 584%     <user>:<realm>:<password>.
 585%     ==
 586%
 587%   The inexpensive MD5 algorithm makes the hash sensitive to brute
 588%   force attacks while the lack of seeding make the hashes sensitive
 589%   for _rainbow table_ attacks, although the value is somewhat limited
 590%   because the _realm_ and _user_ are part of the hash.
 591
 592http_digest_password_hash(User, Realm, Password, HA1) :-
 593    atomics_to_string([User,Realm,Password], ":", A1),
 594    hash(A1, HA1).
 595
 596
 597                 /*******************************
 598                 *   PLUGIN FOR HTTP_DISPATCH   *
 599                 *******************************/
 600
 601:- multifile
 602    http:authenticate/3.
 603
 604%!  http:authenticate(+Digest, +Request, -Fields)
 605%
 606%   Plugin  for  library(http_dispatch)  to    perform   basic  HTTP
 607%   authentication.  Note that we keep the authentication details
 608%   cached to avoid a `nonce-replay' error in the case that the
 609%   application tries to verify multiple times.
 610%
 611%   This predicate throws http_reply(authorise(digest(Digest)))
 612%
 613%   @arg    Digest is a term digest(File, Realm, Options)
 614%   @arg    Request is the HTTP request
 615%   @arg    Fields describes the authenticated user with the option
 616%           user(User) and with the option user_details(Fields) if
 617%           the password file contains additional fields after the
 618%           user and password.
 619
 620http:authenticate(digest(File, Realm), Request, Details) :-
 621    http:authenticate(digest(File, Realm, []), Request, Details).
 622http:authenticate(digest(File, Realm, Options), Request, Details) :-
 623    current_output(CGI),
 624    cgi_property(CGI, id(Id)),
 625    (   nb_current('$http_digest_user', Id-Details)
 626    ->  true
 627    ;   authenticate(digest(File, Realm, Options), Request, Details),
 628        nb_setval('$http_digest_user', Id-Details)
 629    ).
 630
 631authenticate(digest(File, Realm, Options), Request,
 632             [ user(User)
 633             | Details
 634             ]) :-
 635    (   option(method(Method), Request, get),
 636        http_digest_authenticate(Request, [User|Fields],
 637                                 [ passwd_file(File),
 638                                   stale(Stale),
 639                                   method(Method)
 640                                 ])
 641    ->  (   Stale == false
 642        ->  (   Fields == []
 643            ->  Details = []
 644            ;   Details = [user_details(Fields)]
 645            ),
 646            Ok = true
 647        ;   true
 648        )
 649    ;   true
 650    ),
 651    (   Ok == true
 652    ->  true
 653    ;   add_option(nonce(Nonce-Created), Options, Options1),
 654        add_stale(Stale, Options1, Options2),
 655        phrase(http_digest_challenge(Realm, Options2), DigestCodes),
 656        string_codes(Digest, DigestCodes),
 657        register_nonce(Nonce, Created),
 658        throw(http_reply(authorise(digest(Digest))))
 659    ).
 660
 661add_option(Option, Options0, _) :-
 662    option(Option, Options0),
 663    !.
 664add_option(Option, Options0, [Option|Options0]).
 665
 666add_stale(Stale, Options0, Options) :-
 667    Stale == true,
 668    !,
 669    Options = [stale(true)|Options0].
 670add_stale(_, Options, Options).
 671
 672
 673                 /*******************************
 674                 *     PLUGIN FOT HTTP_OPEN     *
 675                 *******************************/
 676
 677:- multifile
 678    http:authenticate_client/2.
 679:- dynamic
 680    client_nonce/4,                 % Authority, Domains, Keep, Time
 681    client_nonce_nc/3,              % Nonce, Count, Time
 682    client_nonce_gc_time/1.         % Time
 683
 684%!  http:authenticate_client(+URL, +Action) is semidet.
 685%
 686%   This hooks is called by http_open/3 with the following Action
 687%   value:
 688%
 689%     - send_auth_header(+AuthData, +Out, +Options)
 690%     Called when sending the initial request.  AuthData contains
 691%     the value for the http_open/3 option authorization(AuthData)
 692%     and Out is a stream on which to write additional HTTP headers.
 693%     - auth_reponse(+Headers, +OptionsIn, -Options)
 694%     Called if the server replies with a 401 code, challenging the
 695%     client.  Our implementation adds a
 696%     request_header(authorization=Digest) header to Options, causing
 697%     http_open/3 to retry the request with the additional option.
 698
 699http:authenticate_client(URL, auth_reponse(Headers, OptionsIn, Options)) :-
 700    debug(http(authenticate), "Got 401 with ~p", [Headers]),
 701    memberchk(www_authenticate(Authenticate), Headers),
 702    http_parse_digest_challenge(Authenticate, Fields),
 703    user_password(OptionsIn, User, Password),
 704    !,
 705    uri_components(URL, Components),
 706    uri_data(path, Components, Path),
 707    http_digest_response(Fields, User, Password, Digest,
 708                             [ path(Path)
 709                             | OptionsIn
 710                             ]),
 711    merge_options([ request_header(authorization=Digest)
 712                  ],
 713                  OptionsIn, Options),
 714    keep_digest_credentials(URL, Fields).
 715http:authenticate_client(URL, send_auth_header(Auth, Out, Options)) :-
 716    authorization_data(Auth, User, Password),
 717    uri_components(URL, Components),
 718    uri_data(authority, Components, Authority),
 719    uri_data(path, Components, Path),
 720    digest_credentials(Authority, Path, Nonce, Fields),
 721    !,
 722    next_nonce_count(Nonce, NC),
 723    debug(http(authenticate), "Continue ~p nc=~q", [URL, NC]),
 724    http_digest_response(Fields, User, Password, Digest,
 725                         [ nc(NC),
 726                           path(Path)
 727                         | Options
 728                         ]),
 729    format(Out, 'Authorization: ~w\r\n', [Digest]).
 730http:authenticate_client(URL, send_auth_header(Auth, _Out, _Options)) :-
 731    debug(http(authenticate), "Failed ~p", [URL]),
 732    authorization_data(Auth, _User, _Password).
 733
 734
 735user_password(Options, User, Password) :-
 736    option(authorization(Auth), Options),
 737    authorization_data(Auth, User, Password).
 738
 739authorization_data(digest(User, Password), User, Password).
 740
 741%!  digest_credentials(+Authority, +Path, -Nonce, -Fields) is semidet.
 742%
 743%   True if we have digest credentials for Authority on Path with the
 744%   server _nonce_ Nonce and additional Fields.
 745
 746digest_credentials(Authority, Path, Nonce, Fields) :-
 747    client_nonce(Authority, Domains, Fields, _Created),
 748    in_domain(Path, Domains),
 749    memberchk(nonce(Nonce), Fields),
 750    !.
 751
 752in_domain(Path, Domains) :-
 753    member(Domain, Domains),
 754    sub_atom(Path, 0, _, _, Domain),
 755    !.
 756
 757next_nonce_count(Nonce, NC) :-
 758    with_mutex(http_digest_client,
 759               next_nonce_count_sync(Nonce, NC)).
 760
 761next_nonce_count_sync(Nonce, NC) :-
 762    retract(client_nonce_nc(Nonce, NC0, _)),
 763    !,
 764    NC1 is NC0+1,
 765    get_time(Now),
 766    assert(client_nonce_nc(Nonce, NC1, Now)),
 767    NC = NC1.
 768next_nonce_count_sync(Nonce, 2) :-
 769    get_time(Now),
 770    assert(client_nonce_nc(Nonce, 2, Now)).
 771
 772%!  keep_digest_credentials(+URL, +Fields)
 773%
 774%   Keep the digest credentials for subsequent connections.
 775
 776keep_digest_credentials(URL, Fields) :-
 777    get_time(Now),
 778    uri_components(URL, Components),
 779    uri_data(authority, Components, Authority),
 780    include(keep_field, Fields, Keep),
 781    (   memberchk(domain(Domains), Fields)
 782    ->  true
 783    ;   Domains = [/]
 784    ),
 785    assertz(client_nonce(Authority, Domains, Keep, Now)),
 786    gc_client_nonce.
 787
 788keep_field(realm(_)).
 789keep_field(nonce(_)).
 790keep_field(opaque(_)).
 791
 792gc_client_nonce :-
 793    client_nonce_gc_time(Last),
 794    get_time(Now),
 795    setting(client_nonce_timeout, TimeOut),
 796    Now-Last < TimeOut/4,
 797    !.
 798gc_client_nonce :-
 799    get_time(Now),
 800    retractall(client_nonce_gc_time(_)),
 801    asserta(client_nonce_gc_time(Now)),
 802    setting(client_nonce_timeout, TimeOut),
 803    Before is Now-TimeOut,
 804    forall(client_nonce_expired(Nonce, Before),
 805           forget_client_nonce(Nonce)).
 806
 807client_nonce_expired(Nonce, Before) :-
 808    client_nonce(_Authority, _Domains, Fields, Created),
 809    Created < Before,
 810    memberchk(nonce(Nonce), Fields),
 811    \+ ( client_nonce_nc(Nonce, _, Last),
 812         Last < Before
 813       ).
 814
 815forget_client_nonce(Nonce) :-
 816    client_nonce(_, _, Fields, Created),
 817    memberchk(nonce(Nonce), Fields),
 818    !,
 819    retractall(client_nonce(_, _, Fields, Created)),
 820    retractall(client_nonce_nc(Nonce, _, _)).