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)).

   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

 http:write_cookies(+Out, +Parts, +Options) is det

Emit a cookie header for the current request.

   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]).

 cookie(+ClientId, +Parts, -Cookie) is semidet

Cookie is the cookie for Parts for the given ClientId

   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    ).

 cookie_value(+NameValueList, -CookieString) is det

Create a cookie value string with name=value, seperated by ";".

  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    ).

 http:update_cookies(+CookieData, +Parts, +Options) is semidet

Update the client cookie database.

  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])).

 remove_cookies(+ClientId, +Host, +Path, +Name, +SetOptions) is det

Remove all cookies that conflict with the new set-cookie command.

  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    ).

 current_cookie(+ClientId, +Host, +Path, -Name, -Value) is nondet

Find cookies that match the given request.

  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    ).

 cookie_remove_client(+ClientId) is det

Fake user quitting a browser. Removes all cookies that do not have an expire date.

  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    ).

 cookie_remove_all_clients is det

Simply logout all clients. See http_remove_client/1.

  221cookie_remove_all_clients :-
  222    forall(current_client(ClientId),
  223           cookie_remove_client(ClientId)).

 current_client(?ClientId) is nondet

True if ClientId is the identifier of a client.

  229current_client(ClientId) :-
  230    client_cookie(ClientId, _CName, _Name, _Value, _Options).

 http_current_cookie(?ClientId, ?Name, ?Value, ?Options) is nondet

Query current cookie database. If Name is given, it is matched case insensitive against the known cookies. If it is unbound, the cookie name is returned in its oiginal case (case preserving).

  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)