34
35:- module(http_cookie,
36 [ cookie_remove_client/1, 37 cookie_remove_all_clients/0,
38 cookie_current_cookie/4 39 ]). 40:- use_module(library(debug),[debug/3]). 41:- autoload(library(option),[option/3]). 42:- autoload(library(http/http_header),[http_parse_header_value/3]). 43
63
64:- multifile
65 http:write_cookies/3, 66 http:update_cookies/3. 67
68:- dynamic
69 client_cookie/5. 70
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
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
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
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
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
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) 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) 190 ; true
191 ).
192
193cookie_match_expire(Options) :-
194 ( memberchk(expire=Expire, Options)
195 -> get_time(Now),
196 Now =< Expire
197 ; true
198 ).
199
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
220
221cookie_remove_all_clients :-
222 forall(current_client(ClientId),
223 cookie_remove_client(ClientId)).
224
228
229current_client(ClientId) :-
230 client_cookie(ClientId, _CName, _Name, _Value, _Options).
231
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)