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, _, _)).
821