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)  2011, 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_cookie,
36          [ cookie_remove_client/1,     % +ClientId
37            cookie_remove_all_clients/0,
38            cookie_current_cookie/4     % ?ClientId, ?Name, ?Value, ?Options
39          ]).
40:- autoload(library(debug),[debug/3]).
41:- autoload(library(option),[option/3]).
42:- autoload(library(http/http_header),[http_parse_header_value/3]).
43
44/** <module> HTTP client cookie handling
45
46This module implements the cookie hooks  called from http_open/3, adding
47cookie handling to the client.
48
49This library supports a notion of _clients_. A client is a (ground) term
50to which a cookie database is  connected.   This  allows a single Prolog
51process to act  as  multiple  clients.   The  default  client  is called
52=default=. Use the option client(+ClientId) to select another client.
53
54The client and cookie database can be  inspected and cleared using these
55predicates.
56
57  * cookie_remove_client/1
58  * cookie_remove_all_clients/0
59  * cookie_current_cookie/4
60
61@tbd add hooks to http_get/3 and http_post/4
62*/
63
64:- multifile
65    http:write_cookies/3,           % +Out, +Parts, +Options
66    http:update_cookies/3.          % +CookieData, +Parts, +Options
67
68:- dynamic
69    client_cookie/5.                % Id, CanName, Name, Value, Options
70
71%!  http:write_cookies(+Out, +Parts, +Options) is det.
72%
73%   Emit a cookie header for the current request.
74
75http:write_cookies(Out, Parts, Options) :-
76    option(client(ClientId), Options, default),
77    cookie(ClientId, Parts, Cookie),
78    format(Out, 'Cookie: ~s\r\n', [Cookie]).
79
80%!  cookie(+ClientId, +Parts, -Cookie) is semidet.
81%
82%   Cookie is the cookie for Parts for the given ClientId
83
84cookie(ClientId, Parts, Cookie) :-
85    request_host(Parts, Host),
86    request_path(Parts, Path),
87    findall(N=V, current_cookie(ClientId, Host, Path, N, V), Cookies),
88    Cookies \== [],
89    !,
90    debug(http(cookie), 'Cookies for ~w at ~w~w: ~p',
91          [ClientId, Host, Path, Cookies]),
92    cookie_value(Cookies, Cookie).
93
94request_host(Parts, Host) :-
95    memberchk(host(Host), Parts).
96
97request_path(Parts, Path) :-
98    (   memberchk(path(Path), Parts)
99    ->  true
100    ;   Path = (/)
101    ).
102
103%!  cookie_value(+NameValueList, -CookieString) is det.
104%
105%   Create a cookie value string with name=value, separated by ";".
106
107cookie_value(List, Cookie) :-
108    with_output_to(string(Cookie),
109                   write_cookies(List)).
110
111write_cookies([]).
112write_cookies([Name=Value|T]) :-
113    format('~w=~w', [Name, Value]),
114    (   T == []
115    ->  true
116    ;   format('; ', []),
117        write_cookies(T)
118    ).
119
120%!  http:update_cookies(+CookieData, +Parts, +Options) is semidet.
121%
122%   Update the client  cookie  database.
123
124http:update_cookies(CookieData, Parts, Options) :-
125    http_parse_header_value(set_cookie, CookieData,
126                            set_cookie(Name, Value, COptions)),
127    !,
128    option(client(ClientId), Options, default),
129    request_host(Parts, Host),
130    request_path(Parts, Path),
131    with_mutex(http_cookie,
132               update_cookie(ClientId, Host, Path, Name, Value, COptions)).
133
134update_cookie(ClientId, Host, Path, Name, Value, Options) :-
135    downcase_atom(Name, CName),
136    remove_cookies(ClientId, Host, Path, CName, Options),
137    debug(http(cookie), 'New for ~w: ~w=~p', [ClientId, Name, Value]),
138    assert(client_cookie(ClientId, CName, Name, Value, [host=Host|Options])).
139
140%!  remove_cookies(+ClientId, +Host, +Path, +Name, +SetOptions) is det.
141%
142%   Remove all cookies that conflict with the new set-cookie
143%   command.
144
145remove_cookies(ClientId, Host, Path, CName, SetOptions) :-
146    (   client_cookie(ClientId, CName, Name, Value, OldOptions),
147        cookie_match_host(Host, SetOptions, OldOptions),
148        cookie_match_path(Path, SetOptions, OldOptions),
149        debug(cookie, 'Del for ~w: ~w=~p', [ClientId, Name, Value]),
150        retract(client_cookie(ClientId, CName, Name, Value, OldOptions)),
151        fail
152    ;   true
153    ).
154
155cookie_match_host(Host, SetOptions, OldOptions) :-
156    (   memberchk(domain=Domain, SetOptions)
157    ->  cookie_match_host(Domain, OldOptions)
158    ;   cookie_match_host(Host, OldOptions)
159    ).
160
161cookie_match_path(Path, SetOptions, OldOptions) :-
162    (   memberchk(path=PathO, SetOptions)
163    ->  cookie_match_path(PathO, OldOptions)
164    ;   cookie_match_path(Path, OldOptions)
165    ).
166
167%!  current_cookie(+ClientId, +Host, +Path, -Name, -Value) is nondet.
168%
169%   Find cookies that match the given request.
170
171current_cookie(ClientId, Host, Path, Name, Value) :-
172    client_cookie(ClientId, _CName, Name, Value, Options),
173    cookie_match_host(Host, Options),
174    cookie_match_path(Path, Options),
175    cookie_match_expire(Options).
176
177cookie_match_host(Host, Options) :-
178    (   memberchk(domain=Domain, Options)
179    ->  downcase_atom(Host, LHost),
180        downcase_atom(Domain, LDomain),
181        sub_atom(LHost, _, _, 0, LDomain)   % TBD: check '.'?
182    ;   memberchk(host=CHost, Options),
183        downcase_atom(Host, LHost),
184        downcase_atom(CHost, LHost)
185    ).
186
187cookie_match_path(Path, Options) :-
188    (   memberchk(path=Root, Options)
189    ->  sub_atom(Path, 0, _, _, Root)       % TBD: check '/'?
190    ;   true
191    ).
192
193cookie_match_expire(Options) :-
194    (   memberchk(expire=Expire, Options)
195    ->  get_time(Now),
196        Now =< Expire
197    ;   true
198    ).
199
200%!  cookie_remove_client(+ClientId) is det.
201%
202%   Fake user quitting a browser.   Removes all cookies that do
203%   not have an expire date.
204
205cookie_remove_client(ClientId) :-
206    var(ClientId),
207    !,
208    throw(error(instantiation_error, _)).
209cookie_remove_client(ClientId) :-
210    (   client_cookie(ClientId, CName, Name, Value, Options),
211        \+ memberchk(expire=_, Options),
212        retract(client_cookie(ClientId, CName, Name, Value, Options)),
213        fail
214    ;   true
215    ).
216
217%!  cookie_remove_all_clients is det.
218%
219%   Simply logout all clients.  See http_remove_client/1.
220
221cookie_remove_all_clients :-
222    forall(current_client(ClientId),
223           cookie_remove_client(ClientId)).
224
225%!  current_client(?ClientId) is nondet.
226%
227%   True if ClientId is the identifier of a client.
228
229current_client(ClientId) :-
230    client_cookie(ClientId, _CName, _Name, _Value, _Options).
231
232%!  http_current_cookie(?ClientId, ?Name, ?Value, ?Options) is nondet.
233%
234%   Query current cookie database. If Name   is given, it is matched
235%   case insensitive against the known cookies.   If  it is unbound,
236%   the  cookie  name  is  returned  in    its  oiginal  case  (case
237%   preserving).
238
239cookie_current_cookie(ClientId, Name, Value, Options) :-
240    nonvar(Name),
241    !,
242    downcase_atom(Name, CName),
243    client_cookie(ClientId, CName, Name, Value, Options).
244cookie_current_cookie(ClientId, Name, Value, Options) :-
245    client_cookie(ClientId, _CName, Name, Value, Options).
246