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:- use_module(library(http/http_header)).   41:- use_module(library(option)).   42:- use_module(library(debug)).   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, seperated 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)