1177 lines
33 KiB
Plaintext
1177 lines
33 KiB
Plaintext
{
|
|
$Project$
|
|
$Workfile$
|
|
$Revision$
|
|
$DateUTC$
|
|
$Id$
|
|
|
|
This file is part of the Indy (Internet Direct) project, and is offered
|
|
under the dual-licensing agreement described on the Indy website.
|
|
(http://www.indyproject.org/)
|
|
|
|
Copyright:
|
|
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
|
}
|
|
{
|
|
$Log$
|
|
}
|
|
{
|
|
Rev 1.6 2004.10.27 9:17:46 AM czhower
|
|
For TIdStrings
|
|
|
|
Rev 1.5 10/26/2004 11:08:08 PM JPMugaas
|
|
Updated refs.
|
|
|
|
Rev 1.4 13.04.2004 12:56:44 ARybin
|
|
M$ IE behavior
|
|
|
|
Rev 1.3 2004.02.03 5:45:00 PM czhower
|
|
Name changes
|
|
|
|
Rev 1.2 2004.01.22 6:09:02 PM czhower
|
|
IdCriticalSection
|
|
|
|
Rev 1.1 1/22/2004 7:09:58 AM JPMugaas
|
|
Tried to fix AnsiSameText depreciation.
|
|
|
|
Rev 1.0 11/14/2002 02:16:20 PM JPMugaas
|
|
|
|
Mar-31-2001 Doychin Bondzhev
|
|
- Changes in the class heirarchy to implement Netscape specification[Netscape],
|
|
RFC 2109[RFC2109] & 2965[RFC2965]
|
|
|
|
Feb-2001 Doychin Bondzhev
|
|
- Initial release
|
|
}
|
|
|
|
unit IdCookie;
|
|
|
|
{
|
|
Implementation of the HTTP State Management Mechanism as specified in RFC 6265.
|
|
Author: Remy Lebeau (remy@lebeausoftware.org)
|
|
Copyright: (c) Chad Z. Hower and The Indy Team.
|
|
|
|
TIdCookie - The base code used in all cookies.
|
|
|
|
REFERENCES
|
|
-------------------
|
|
[RFC6265] Barth, A, "HTTP State Management Mechanism",
|
|
RFC 6265, April 2011.
|
|
|
|
[DRAFT-ORIGIN-01] Pettersen, Y, "Identifying origin server of HTTP Cookies",
|
|
Internet-Draft, March 07, 2010.
|
|
http://www.ietf.org/id/draft-pettersen-cookie-origin-01.txt
|
|
|
|
[DRAFT-COOKIEv2-05] Pettersen, Y, "HTTP State Management Mechanism v2",
|
|
Internet-Draft, March 07, 2010.
|
|
http://www.ietf.org/id/draft-pettersen-cookie-v2-05.txt
|
|
}
|
|
|
|
interface
|
|
|
|
{$I IdCompilerDefines.inc}
|
|
|
|
uses
|
|
Classes,
|
|
{$IFDEF HAS_UNIT_Generics_Collections}
|
|
System.Generics.Collections,
|
|
{$ENDIF}
|
|
IdGlobal, IdException, IdGlobalProtocols, IdURI,
|
|
SysUtils;
|
|
|
|
type
|
|
{ Base Cookie class as described in [RFC6265] }
|
|
TIdCookie = class(TCollectionItem)
|
|
protected
|
|
FDomain: String;
|
|
FExpires: TDateTime;
|
|
FHttpOnly: Boolean;
|
|
FName: String;
|
|
FPath: String;
|
|
FSecure: Boolean;
|
|
FValue: String;
|
|
FCreatedAt: TDateTime;
|
|
FHostOnly: Boolean;
|
|
FLastAccessed: TDateTime;
|
|
FPersistent: Boolean;
|
|
|
|
function GetIsExpired: Boolean;
|
|
|
|
function GetServerCookie: String; virtual;
|
|
function GetClientCookie: String; virtual;
|
|
|
|
function GetMaxAge: Int64;
|
|
|
|
public
|
|
constructor Create(ACollection: TCollection); override;
|
|
destructor Destroy; override;
|
|
|
|
procedure Assign(Source: TPersistent); override;
|
|
|
|
function IsAllowed(AURI: TIdURI; SecureOnly: Boolean): Boolean; virtual;
|
|
|
|
function ParseClientCookie(const ACookieText: String): Boolean; virtual;
|
|
function ParseServerCookie(const ACookieText: String; AURI: TIdURI): Boolean; virtual;
|
|
|
|
property ClientCookie: String read GetClientCookie;
|
|
property CookieName: String read FName write FName;
|
|
property CookieText: String read GetServerCookie; // {$IFDEF HAS_DEPRECATED}deprecated{$IFDEF HAS_DEPECATED_MSG} 'Use ServerCookie property instead'{$ENDIF};{$ENDIF}
|
|
property Domain: String read FDomain write FDomain;
|
|
property Expires: TDateTime read FExpires write FExpires;
|
|
property HttpOnly: Boolean read FHttpOnly write FHttpOnly;
|
|
property Path: String read FPath write FPath;
|
|
property Secure: Boolean read FSecure write FSecure;
|
|
property ServerCookie: String read GetServerCookie;
|
|
property Value: String read FValue write FValue;
|
|
|
|
property MaxAge: Int64 read GetMaxAge;
|
|
|
|
property CreatedAt: TDateTime read FCreatedAt write FCreatedAt;
|
|
property IsExpired: Boolean read GetIsExpired;
|
|
property HostOnly: Boolean read FHostOnly write FHostOnly;
|
|
property LastAccessed: TDateTime read FLastAccessed write FLastAccessed;
|
|
property Persistent: Boolean read FPersistent write FPersistent;
|
|
end;
|
|
|
|
TIdCookieClass = class of TIdCookie;
|
|
|
|
{ The Cookie collection }
|
|
|
|
{$IFDEF HAS_GENERICS_TList}
|
|
TIdCookieList = TList<TIdCookie>;
|
|
{$ELSE}
|
|
TIdCookieList = class(TList)
|
|
protected
|
|
function GetCookie(Index: Integer): TIdCookie;
|
|
procedure SetCookie(Index: Integer; AValue: TIdCookie);
|
|
public
|
|
function IndexOfCookie(ACookie: TIdCookie): Integer;
|
|
property Cookies[Index: Integer]: TIdCookie read GetCookie write SetCookie; default;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
TIdCookieAccess = (caRead, caReadWrite);
|
|
|
|
TIdCookies = class(TOwnedCollection)
|
|
protected
|
|
FCookieList: TIdCookieList;
|
|
FRWLock: TMultiReadExclusiveWriteSynchronizer;
|
|
|
|
function GetCookieByNameAndDomain(const AName, ADomain: string): TIdCookie;
|
|
function GetCookie(Index: Integer): TIdCookie;
|
|
procedure SetCookie(Index: Integer; const Value: TIdCookie);
|
|
|
|
public
|
|
constructor Create(AOwner: TPersistent);
|
|
destructor Destroy; override;
|
|
|
|
function Add: TIdCookie; reintroduce;
|
|
function AddCookie(ACookie: TIdCookie; AURI: TIdURI; AReplaceOld: Boolean = True): Boolean;
|
|
|
|
function AddClientCookie(const ACookie: string): TIdCookie;
|
|
procedure AddClientCookies(const ACookie: string); overload;
|
|
procedure AddClientCookies(const ACookies: TStrings); overload;
|
|
|
|
function AddServerCookie(const ACookie: string; AURI: TIdURI): TIdCookie;
|
|
procedure AddServerCookies(const ACookies: TStrings; AURI: TIdURI);
|
|
|
|
procedure AddCookies(ASource: TIdCookies);
|
|
|
|
procedure Assign(ASource: TPersistent); override;
|
|
procedure Clear; reintroduce;
|
|
|
|
function GetCookieIndex(const AName: string; FirstIndex: Integer = 0): Integer; overload;
|
|
function GetCookieIndex(const AName, ADomain: string; FirstIndex: integer = 0): Integer; overload;
|
|
|
|
function LockCookieList(AAccessType: TIdCookieAccess): TIdCookieList;
|
|
procedure UnlockCookieList(AAccessType: TIdCookieAccess);
|
|
|
|
property Cookie[const AName, ADomain: string]: TIdCookie read GetCookieByNameAndDomain;
|
|
property Cookies[Index: Integer]: TIdCookie read GetCookie write SetCookie; Default;
|
|
end;
|
|
|
|
EIdCookieError = class(EIdException);
|
|
|
|
function IsDomainMatch(const AUriHost, ACookieDomain: String): Boolean;
|
|
function IsPathMatch(const AUriPath, ACookiePath: String): Boolean;
|
|
|
|
function CanonicalizeHostName(const AHost: String): String;
|
|
|
|
implementation
|
|
|
|
uses
|
|
{$IFDEF VCL_XE3_OR_ABOVE}
|
|
System.Types,
|
|
{$ENDIF}
|
|
IdAssignedNumbers, IdResourceStringsProtocols;
|
|
|
|
function GetDefaultPath(const AURL: TIdURI): String;
|
|
var
|
|
Idx: Integer;
|
|
begin
|
|
{
|
|
Per RFC 6265, Section 5.1.4:
|
|
|
|
The user agent MUST use an algorithm equivalent to the following
|
|
algorithm to compute the default-path of a cookie:
|
|
|
|
1. Let uri-path be the path portion of the request-uri if such a
|
|
portion exists (and empty otherwise). For example, if the
|
|
request-uri contains just a path (and optional query string),
|
|
then the uri-path is that path (without the %x3F ("?") character
|
|
or query string), and if the request-uri contains a full
|
|
absoluteURI, the uri-path is the path component of that URI.
|
|
|
|
2. If the uri-path is empty or if the first character of the uri-
|
|
path is not a %x2F ("/") character, output %x2F ("/") and skip
|
|
the remaining steps.
|
|
|
|
3. If the uri-path contains no more than one %x2F ("/") character,
|
|
output %x2F ("/") and skip the remaining steps.
|
|
|
|
4. Output the characters of the uri-path from the first character up
|
|
to, but not including, the right-most %x2F ("/").
|
|
}
|
|
|
|
if TextStartsWith(AURL.Path, '/') then begin {do not localize}
|
|
Idx := RPos('/', AURL.Path); {do not localize}
|
|
if Idx > 1 then begin
|
|
Result := Copy(AURL.Path, 1, Idx-1);
|
|
Exit;
|
|
end;
|
|
end;
|
|
Result := '/'; {do not localize}
|
|
end;
|
|
|
|
function CanonicalizeHostName(const AHost: String): String;
|
|
begin
|
|
// TODO: implement this
|
|
{
|
|
Per RFC 6265 Section 5.1.2:
|
|
|
|
A canonicalized host name is the string generated by the following
|
|
algorithm:
|
|
|
|
1. Convert the host name to a sequence of individual domain name
|
|
labels.
|
|
|
|
2. Convert each label that is not a Non-Reserved LDH (NR_LDH) label,
|
|
to an A-label (see Section 2.3.2.1 of [RFC5890] for the fomer
|
|
and latter), or to a "punycode label" (a label resulting from the
|
|
"ToASCII" conversion in Section 4 of [RFC3490]), as appropriate
|
|
(see Section 6.3 of this specification).
|
|
|
|
3. Concatentate the resulting labels, separated by a %x2E (".")
|
|
character.
|
|
}
|
|
Result := AHost;
|
|
end;
|
|
|
|
function IsDomainMatch(const AUriHost, ACookieDomain: String): Boolean;
|
|
var
|
|
LHost, LDomain: String;
|
|
begin
|
|
{
|
|
Per RFC 6265 Section 5.1.3:
|
|
|
|
A string domain-matches a given domain string if at least one of the
|
|
following conditions hold:
|
|
|
|
o The domain string and the string are identical. (Note that both
|
|
the domain string and the string will have been canonicalized to
|
|
lower case at this point.)
|
|
|
|
o All of the following conditions hold:
|
|
|
|
* The domain string is a suffix of the string.
|
|
|
|
* The last character of the string that is not included in the
|
|
domain string is a %x2E (".") character.
|
|
|
|
* The string is a host name (i.e., not an IP address).
|
|
}
|
|
|
|
Result := False;
|
|
LHost := CanonicalizeHostName(AUriHost);
|
|
LDomain := CanonicalizeHostName(ACookieDomain);
|
|
if (LHost <> '') and (LDomain <> '') then begin
|
|
if TextIsSame(LHost, LDomain) then begin
|
|
Result := True;
|
|
end
|
|
else if TextEndsWith(LHost, LDomain) then
|
|
begin
|
|
if TextEndsWith(Copy(LHost, 1, Length(LHost)-Length(LDomain)), '.') then begin
|
|
Result := IsHostName(LHost);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function IsPathMatch(const AUriPath, ACookiePath: String): Boolean;
|
|
begin
|
|
{
|
|
Per RFC 6265 Section 5.1.4:
|
|
|
|
A request-path path-matches a given cookie-path if at least one of
|
|
the following conditions hold:
|
|
|
|
o The cookie-path and the request-path are identical.
|
|
|
|
o The cookie-path is a prefix of the request-path and the last
|
|
character of the cookie-path is %x2F ("/").
|
|
|
|
o The cookie-path is a prefix of the request-path and the first
|
|
character of the request-path that is not included in the cookie-
|
|
path is a %x2F ("/") character.
|
|
}
|
|
Result := TextIsSame(AUriPath, ACookiePath) or
|
|
(
|
|
TextStartsWith(AUriPath, ACookiePath) and
|
|
(
|
|
TextEndsWith(ACookiePath, '/') or
|
|
CharEquals(AUriPath, Length(ACookiePath)+1, '/')
|
|
)
|
|
);
|
|
end;
|
|
|
|
function IsHTTP(const AProtocol: String): Boolean;
|
|
begin
|
|
Result := PosInStrArray(AProtocol, ['http', 'https'], False) <> -1; {do not localize}
|
|
end;
|
|
|
|
{ base functions used for construction of Cookie text }
|
|
|
|
procedure AddCookieProperty(var VCookie: String;
|
|
const AProperty, AValue: String);
|
|
begin
|
|
if Length(AValue) > 0 then
|
|
begin
|
|
if Length(VCookie) > 0 then begin
|
|
VCookie := VCookie + '; '; {Do not Localize}
|
|
end;
|
|
// TODO: encode illegal characters?
|
|
VCookie := VCookie + AProperty + '=' + AValue; {Do not Localize}
|
|
end;
|
|
end;
|
|
|
|
procedure AddCookieFlag(var VCookie: String; const AFlag: String);
|
|
begin
|
|
if Length(VCookie) > 0 then begin
|
|
VCookie := VCookie + '; '; { Do not Localize }
|
|
end;
|
|
VCookie := VCookie + AFlag;
|
|
end;
|
|
|
|
{ TIdCookieList }
|
|
|
|
{$IFNDEF HAS_GENERICS_TList}
|
|
|
|
function TIdCookieList.GetCookie(Index: Integer): TIdCookie;
|
|
begin
|
|
Result := TIdCookie(Items[Index]);
|
|
end;
|
|
|
|
procedure TIdCookieList.SetCookie(Index: Integer; AValue: TIdCookie);
|
|
begin
|
|
Items[Index] := AValue;
|
|
end;
|
|
|
|
function TIdCookieList.IndexOfCookie(ACookie: TIdCookie): Integer;
|
|
begin
|
|
for Result := 0 to Count - 1 do
|
|
begin
|
|
if GetCookie(Result) = ACookie then begin
|
|
Exit;
|
|
end;
|
|
end;
|
|
Result := -1;
|
|
end;
|
|
|
|
{$ENDIF}
|
|
|
|
{ TIdCookie }
|
|
|
|
constructor TIdCookie.Create(ACollection: TCollection);
|
|
begin
|
|
inherited Create(ACollection);
|
|
FCreatedAt := Now;
|
|
FLastAccessed := FCreatedAt;
|
|
end;
|
|
|
|
destructor TIdCookie.Destroy;
|
|
var
|
|
LCookieList: TIdCookieList;
|
|
begin
|
|
try
|
|
if Assigned(Collection) then
|
|
begin
|
|
LCookieList := TIdCookies(Collection).LockCookieList(caReadWrite);
|
|
try
|
|
LCookieList.Remove(Self);
|
|
finally
|
|
TIdCookies(Collection).UnlockCookieList(caReadWrite);
|
|
end;
|
|
end;
|
|
finally
|
|
inherited Destroy;
|
|
end;
|
|
end;
|
|
|
|
procedure TIdCookie.Assign(Source: TPersistent);
|
|
var
|
|
LSource: TIdCookie;
|
|
begin
|
|
if Source is TIdCookie then
|
|
begin
|
|
LSource := TIdCookie(Source);
|
|
FDomain := LSource.FDomain;
|
|
FExpires := LSource.FExpires;
|
|
FHttpOnly := LSource.FHttpOnly;
|
|
FName := LSource.FName;
|
|
FPath := LSource.FPath;
|
|
FSecure := LSource.FSecure;
|
|
FValue := LSource.FValue;
|
|
FCreatedAt := LSource.FCreatedAt;
|
|
FHostOnly := LSource.FHostOnly;
|
|
FLastAccessed := LSource.FLastAccessed;
|
|
FPersistent := LSource.FPersistent;
|
|
end else
|
|
begin
|
|
inherited Assign(Source);
|
|
end;
|
|
end;
|
|
|
|
function TIdCookie.IsAllowed(AURI: TIdURI; SecureOnly: Boolean): Boolean;
|
|
|
|
function MatchesHost: Boolean;
|
|
begin
|
|
if HostOnly then begin
|
|
Result := TextIsSame(CanonicalizeHostName(AURI.Host), Domain);
|
|
end else begin
|
|
Result := IsDomainMatch(AURI.Host, Domain);
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
// using the algorithm defined in RFC 6265 section 5.4...
|
|
Result := MatchesHost and IsPathMatch(AURI.Path, Path) and
|
|
((not Secure) or (Secure and SecureOnly)) and
|
|
((not HttpOnly) or (HttpOnly and IsHTTP(AURI.Protocol)));
|
|
end;
|
|
|
|
{$IFNDEF HAS_TryStrToInt64}
|
|
// TODO: move this to IdGlobalProtocols...
|
|
function TryStrToInt64(const S: string; out Value: Int64): Boolean;
|
|
{$IFDEF USE_INLINE}inline;{$ENDIF}
|
|
var
|
|
E: Integer;
|
|
begin
|
|
Val(S, Value, E);
|
|
Result := E = 0;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
function TIdCookie.ParseServerCookie(const ACookieText: String; AURI: TIdURI): Boolean;
|
|
const
|
|
cTokenSeparators = '()<>@,;:\"/[]?={} '#9;
|
|
|
|
procedure SplitCookieText(const CookieProp: TStringList; const S: string);
|
|
var
|
|
LNameValue, LAttrs, LAttr, LName, LValue: String;
|
|
LSecs: Int64;
|
|
LExpiryTime: TDateTime;
|
|
i: Integer;
|
|
begin
|
|
I := Pos(';', ACookieText);
|
|
if I > 0 then
|
|
begin
|
|
LNameValue := Copy(ACookieText, 1, I-1);
|
|
LAttrs := Copy(ACookieText, I, MaxInt);
|
|
end else
|
|
begin
|
|
LNameValue := ACookieText;
|
|
LAttrs := '';
|
|
end;
|
|
|
|
I := Pos('=', LNameValue);
|
|
if I = 0 then begin
|
|
Exit;
|
|
end;
|
|
|
|
LName := Trim(Copy(LNameValue, 1, I-1));
|
|
if LName = '' then begin
|
|
Exit;
|
|
end;
|
|
|
|
LValue := Trim(Copy(LNameValue, I+1, MaxInt));
|
|
if TextStartsWith(LValue, '"') then begin
|
|
IdDelete(LValue, 1, 1);
|
|
LNameValue := LValue;
|
|
LValue := Fetch(LNameValue, '"');
|
|
end;
|
|
CookieProp.Add(LName + '=' + LValue);
|
|
|
|
while LAttrs <> '' do
|
|
begin
|
|
IdDelete(LAttrs, 1, 1);
|
|
I := Pos(';', LAttrs);
|
|
if I > 0 then begin
|
|
LAttr := Copy(LAttrs, 1, I-1);
|
|
LAttrs := Copy(LAttrs, I, MaxInt);
|
|
end else begin
|
|
LAttr := LAttrs;
|
|
LAttrs := '';
|
|
end;
|
|
I := Pos('=', LAttr);
|
|
if I > 0 then begin
|
|
LName := Trim(Copy(LAttr, 1, I-1));
|
|
LValue := Trim(Copy(LAttr, I+1, MaxInt));
|
|
// RLebeau: RFC 6265 does not account for quoted attribute values,
|
|
// despite several complaints asking for it. We'll do it anyway in
|
|
// the hopes that the RFC will be updated to "do the right thing"...
|
|
if TextStartsWith(LValue, '"') then begin
|
|
IdDelete(LValue, 1, 1);
|
|
LNameValue := LValue;
|
|
LValue := Fetch(LNameValue, '"');
|
|
end;
|
|
end else begin
|
|
LName := Trim(LAttr);
|
|
LValue := '';
|
|
end;
|
|
|
|
case PosInStrArray(LName, ['Expires', 'Max-Age', 'Domain', 'Path', 'Secure', 'HttpOnly'], False) of
|
|
0: begin
|
|
if TryStrToInt64(LValue, LSecs) then begin
|
|
// Not in the RFCs, but some servers specify Expires as an
|
|
// integer number in seconds instead of using Max-Age...
|
|
if LSecs >= 0 then begin
|
|
// TODO: use SecsPerDay instead:
|
|
// LExpiryTime := (Now + (LSecs / SecsPerDay));
|
|
LExpiryTime := (Now + LSecs * 1000 / MSecsPerDay);
|
|
end else begin
|
|
LExpiryTime := EncodeDate(1, 1, 1);
|
|
end;
|
|
CookieProp.Add('EXPIRES=' + FloatToStr(LExpiryTime));
|
|
end else
|
|
begin
|
|
LExpiryTime := CookieStrToLocalDateTime(LValue);
|
|
if LExpiryTime <> 0.0 then begin
|
|
CookieProp.Add('EXPIRES=' + FloatToStr(LExpiryTime));
|
|
end;
|
|
end;
|
|
end;
|
|
1: begin
|
|
if TryStrToInt64(LValue, LSecs) then begin
|
|
if LSecs >= 0 then begin
|
|
// TODO: use SecsPerDay instead:
|
|
// LExpiryTime := (Now + (LSecs / SecsPerDay));
|
|
LExpiryTime := (Now + LSecs * 1000 / MSecsPerDay);
|
|
end else begin
|
|
LExpiryTime := EncodeDate(1, 1, 1);
|
|
end;
|
|
CookieProp.Add('MAX-AGE=' + FloatToStr(LExpiryTime));
|
|
end;
|
|
end;
|
|
2: begin
|
|
if LValue <> '' then begin
|
|
if TextStartsWith(LValue, '.') then begin {do not localize}
|
|
LValue := Copy(LValue, 2, MaxInt);
|
|
end;
|
|
// RLebeau: have encountered one cookie in the 'Set-Cookie' header that
|
|
// includes a port number in the domain, though the RFCs do not indicate
|
|
// this is allowed. RFC 2965 defines an explicit "port" attribute in the
|
|
// 'Set-Cookie2' header for that purpose instead. We'll just strip it off
|
|
// here if present...
|
|
I := Pos(':', LValue);
|
|
if I > 0 then begin
|
|
LValue := Copy(S, 1, I-1);
|
|
end;
|
|
CookieProp.Add('DOMAIN=' + LowerCase(LValue));
|
|
end;
|
|
end;
|
|
3: begin
|
|
if (LValue = '') or (not TextStartsWith(LValue, '/')) then begin
|
|
LValue := GetDefaultPath(AURI);
|
|
end;
|
|
CookieProp.Add('PATH=' + LValue);
|
|
end;
|
|
4: begin
|
|
CookieProp.Add('SECURE=');
|
|
end;
|
|
5: begin
|
|
CookieProp.Add('HTTPONLY=');
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function GetLastValueOf(const CookieProp: TStringList; const AName: String; var VValue: String): Boolean;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
Result := False;
|
|
for I := CookieProp.Count-1 downto 0 do
|
|
begin
|
|
if TextIsSame(CookieProp.Names[I], AName) then
|
|
begin
|
|
VValue := IndyValueFromIndex(CookieProp, I);
|
|
Result := True;
|
|
Exit;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
//Darcy: moved down the variables! Android compiler... bad boy!
|
|
var
|
|
CookieProp: TStringList;
|
|
S: string;
|
|
begin
|
|
Result := False;
|
|
|
|
// using the algorithm defined in RFC 6265 section 5.2...
|
|
|
|
CookieProp := TStringList.Create;
|
|
try
|
|
SplitCookieText(CookieProp, S);
|
|
if CookieProp.Count = 0 then begin
|
|
Exit;
|
|
end;
|
|
|
|
FName := CookieProp.Names[0];
|
|
FValue := IndyValueFromIndex(CookieProp, 0);
|
|
CookieProp.Delete(0);
|
|
|
|
FCreatedAt := Now;
|
|
FLastAccessed := FCreatedAt;
|
|
|
|
// using the algorithms defined in RFC 6265 section 5.3...
|
|
|
|
if GetLastValueOf(CookieProp, 'MAX-AGE', S) then begin {Do not Localize}
|
|
FPersistent := True;
|
|
FExpires := StrToFloat(S);
|
|
end
|
|
else if GetLastValueOf(CookieProp, 'EXPIRES', S) then {Do not Localize}
|
|
begin
|
|
FPersistent := True;
|
|
FExpires := StrToFloat(S);
|
|
end else
|
|
begin
|
|
FPersistent := False;
|
|
FExpires := EncodeDate(9999, 12, 31) + EncodeTime(23, 59, 59, 999);
|
|
end;
|
|
|
|
S := '';
|
|
if GetLastValueOf(CookieProp, 'DOMAIN', S) then {Do not Localize}
|
|
begin
|
|
// TODO
|
|
{
|
|
If the user agent is configured to reject "public suffixes" and
|
|
the domain-attribute is a public suffix:
|
|
|
|
If the domain-attribute is identical to the canonicalized
|
|
request-host:
|
|
|
|
Let the domain-attribute be the empty string.
|
|
|
|
Otherwise:
|
|
|
|
Ignore the cookie entirely and abort these steps.
|
|
|
|
NOTE: A "public suffix" is a domain that is controlled by a
|
|
public registry, such as "com", "co.uk", and "pvt.k12.wy.us".
|
|
This step is essential for preventing attacker.com from
|
|
disrupting the integrity of example.com by setting a cookie
|
|
with a Domain attribute of "com". Unfortunately, the set of
|
|
public suffixes (also known as "registry controlled domains")
|
|
changes over time. If feasible, user agents SHOULD use an
|
|
up-to-date public suffix list, such as the one maintained by
|
|
the Mozilla project at <http://publicsuffix.org/>.
|
|
}
|
|
{
|
|
if RejectPublicSuffixes and IsPublicSuffix(S) then begin
|
|
if S <> CanonicalizeHostName(AURI.Host) then begin
|
|
Exit;
|
|
end;
|
|
S := '';
|
|
end;
|
|
}
|
|
end;
|
|
|
|
if Length(S) > 0 then
|
|
begin
|
|
if not IsDomainMatch(AURI.Host, S) then begin
|
|
Exit;
|
|
end;
|
|
FHostOnly := False;
|
|
FDomain := S;
|
|
end else
|
|
begin
|
|
FHostOnly := True;
|
|
FDomain := CanonicalizeHostName(AURI.Host);
|
|
end;
|
|
|
|
if GetLastValueOf(CookieProp, 'PATH', S) then begin {Do not Localize}
|
|
FPath := S;
|
|
end else begin
|
|
FPath := GetDefaultPath(AURI);
|
|
end;
|
|
|
|
FSecure := CookieProp.IndexOfName('SECURE') <> -1; { Do not Localize }
|
|
FHttpOnly := CookieProp.IndexOfName('HTTPONLY') <> -1; { Do not Localize }
|
|
|
|
if FHttpOnly and (not IsHTTP(AURI.Protocol)) then begin
|
|
Exit;
|
|
end;
|
|
|
|
Result := True;
|
|
finally
|
|
FreeAndNil(CookieProp);
|
|
end;
|
|
end;
|
|
|
|
function TIdCookie.GetIsExpired: Boolean;
|
|
begin
|
|
Result := (FExpires <> 0.0) and (FExpires < Now);
|
|
end;
|
|
|
|
function TIdCookie.GetMaxAge: Int64;
|
|
begin
|
|
if FExpires <> 0.0 then begin
|
|
Result := Trunc((FExpires - Now) * MSecsPerDay / 1000);
|
|
end else begin
|
|
Result := -1;
|
|
end;
|
|
end;
|
|
|
|
{
|
|
set-cookie-header = "Set-Cookie:" SP set-cookie-string
|
|
set-cookie-string = cookie-pair *( ";" SP cookie-av )
|
|
cookie-pair = cookie-name "=" cookie-value
|
|
cookie-name = token
|
|
cookie-value = *cookie-octet / ( DQUOTE *cookie-octet DQUOTE )
|
|
cookie-octet = %x21 / %x23-2B / %x2D-3A / %x3C-5B / %x5D-7E
|
|
; US-ASCII characters excluding CTLs,
|
|
; whitespace DQUOTE, comma, semicolon,
|
|
; and backslash
|
|
token = <token, defined in [RFC2616], Section 2.2>
|
|
|
|
cookie-av = expires-av / max-age-av / domain-av /
|
|
path-av / secure-av / httponly-av /
|
|
extension-av
|
|
expires-av = "Expires=" sane-cookie-date
|
|
sane-cookie-date = <rfc1123-date, defined in [RFC2616], Section 3.3.1>
|
|
max-age-av = "Max-Age=" non-zero-digit *DIGIT
|
|
; In practice, both expires-av and max-age-av
|
|
; are limited to dates representable by the
|
|
; user agent.
|
|
non-zero-digit = %x31-39
|
|
; digits 1 through 9
|
|
domain-av = "Domain=" domain-value
|
|
domain-value = <subdomain>
|
|
; defined in [RFC1034], Section 3.5, as
|
|
; enhanced by [RFC1123], Section 2.1
|
|
path-av = "Path=" path-value
|
|
path-value = <any CHAR except CTLs or ";">
|
|
secure-av = "Secure"
|
|
httponly-av = "HttpOnly"
|
|
extension-av = <any CHAR except CTLs or ";">
|
|
}
|
|
function TIdCookie.GetServerCookie: String;
|
|
var
|
|
LExpires: TDateTime;
|
|
LMaxAge: Int64;
|
|
begin
|
|
Result := FName + '=' + FValue; {Do not Localize}
|
|
AddCookieProperty(Result, 'Path', FPath); {Do not Localize}
|
|
AddCookieProperty(Result, 'Domain', FDomain); {Do not Localize}
|
|
if FSecure then begin
|
|
AddCookieFlag(Result, 'Secure'); {Do not Localize}
|
|
end;
|
|
if FHttpOnly then begin
|
|
AddCookieFlag(Result, 'HttpOnly'); {Do not Localize}
|
|
end;
|
|
LMaxAge := MaxAge;
|
|
if LMaxAge >= 0 then begin
|
|
AddCookieProperty(Result, 'Max-Age', IntToStr(LMaxAge)); {Do not Localize}
|
|
end;
|
|
LExpires := Expires;
|
|
if LExpires <> 0.0 then begin
|
|
AddCookieProperty(Result, 'Expires', LocalDateTimeToCookieStr(LExpires)); {Do not Localize}
|
|
end;
|
|
end;
|
|
|
|
{
|
|
Cookie: NAME1=OPAQUE_STRING1; NAME2=OPAQUE_STRING2 ...
|
|
}
|
|
function TIdCookie.GetClientCookie: String;
|
|
begin
|
|
Result := FName + '=' + FValue;
|
|
end;
|
|
|
|
{
|
|
cookie-header = "Cookie:" OWS cookie-string OWS
|
|
cookie-string = cookie-pair *( ";" SP cookie-pair )
|
|
}
|
|
function TIdCookie.ParseClientCookie(const ACookieText: String): Boolean;
|
|
var
|
|
CookieProp: TStringList;
|
|
|
|
procedure SplitCookieText;
|
|
var
|
|
LTemp, LName, LValue: String;
|
|
i: Integer;
|
|
IsFlag: Boolean;
|
|
begin
|
|
LTemp := Trim(ACookieText);
|
|
while LTemp <> '' do {Do not Localize}
|
|
begin
|
|
i := FindFirstOf('=;', LTemp); {Do not Localize}
|
|
if i = 0 then begin
|
|
CookieProp.Add(LTemp);
|
|
Break;
|
|
end;
|
|
IsFlag := (LTemp[i] = ';'); {Do not Localize}
|
|
LName := TrimRight(Copy(LTemp, 1, i-1));
|
|
LTemp := TrimLeft(Copy(LTemp, i+1, MaxInt));
|
|
LValue := '';
|
|
if (not IsFlag) and (LTemp <> '') then
|
|
begin
|
|
if TextStartsWith(LTemp, '"') then {Do not Localize}
|
|
begin
|
|
IdDelete(LTemp, 1, 1);
|
|
LValue := Fetch(LTemp, '"'); {Do not Localize}
|
|
Fetch(LTemp, ';'); {Do not Localize}
|
|
end else begin
|
|
LValue := Trim(Fetch(LTemp, ';')); {Do not Localize}
|
|
end;
|
|
LTemp := TrimLeft(LTemp);
|
|
end;
|
|
if LName <> '' then begin
|
|
CookieProp.Add(LName + '=' + LValue); {Do not Localize}
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
Result := False;
|
|
|
|
CookieProp := TStringList.Create;
|
|
try
|
|
SplitCookieText;
|
|
if CookieProp.Count = 0 then begin
|
|
Exit;
|
|
end;
|
|
|
|
FName := CookieProp.Names[0];
|
|
FValue := IndyValueFromIndex(CookieProp, 0);
|
|
|
|
Result := True;
|
|
finally
|
|
FreeAndNil(CookieProp);
|
|
end;
|
|
end;
|
|
|
|
{ TIdCookies }
|
|
|
|
constructor TIdCookies.Create(AOwner: TPersistent);
|
|
begin
|
|
inherited Create(AOwner, TIdCookie);
|
|
FRWLock := TMultiReadExclusiveWriteSynchronizer.Create;
|
|
FCookieList := TIdCookieList.Create;
|
|
end;
|
|
|
|
destructor TIdCookies.Destroy;
|
|
begin
|
|
// This will force the Cookie removing process before we free FCookieList and FRWLock
|
|
Self.Clear;
|
|
FreeAndNil(FCookieList);
|
|
FreeAndNil(FRWLock);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TIdCookies.Add: TIdCookie;
|
|
begin
|
|
Result := TIdCookie(inherited Add);
|
|
end;
|
|
|
|
function TIdCookies.AddCookie(ACookie: TIdCookie; AURI: TIdURI; AReplaceOld: Boolean = True): Boolean;
|
|
var
|
|
LOldCookie: TIdCookie;
|
|
I: Integer;
|
|
begin
|
|
Result := False;
|
|
LockCookieList(caReadWrite);
|
|
try
|
|
if AReplaceOld then
|
|
begin
|
|
for I := 0 to FCookieList.Count-1 do
|
|
begin
|
|
LOldCookie := FCookieList[I];
|
|
if not TextIsSame(LOldCookie.CookieName, ACookie.CookieName) then begin
|
|
Continue;
|
|
end;
|
|
if not TextIsSame(LOldCookie.Domain, ACookie.Domain) then begin
|
|
Continue;
|
|
end;
|
|
if not TextIsSame(LOldCookie.Path, ACookie.Path) then begin
|
|
Continue;
|
|
end;
|
|
if ((AURI <> nil) and (not IsHTTP(AURI.Protocol))) and LOldCookie.HttpOnly then begin
|
|
Exit;
|
|
end;
|
|
ACookie.FCreatedAt := LOldCookie.CreatedAt;
|
|
FCookieList.Delete(I);
|
|
LOldCookie.Collection := nil;
|
|
LOldCookie.Free;
|
|
Break;
|
|
end;
|
|
end;
|
|
if not ACookie.IsExpired then begin
|
|
FCookieList.Add(ACookie);
|
|
Result := True;
|
|
end;
|
|
finally
|
|
UnlockCookieList(caReadWrite);
|
|
end;
|
|
end;
|
|
|
|
procedure TIdCookies.Assign(ASource: TPersistent);
|
|
begin
|
|
if (ASource = nil) or (ASource is TIdCookies) then
|
|
begin
|
|
LockCookieList(caReadWrite);
|
|
try
|
|
Clear;
|
|
AddCookies(TIdCookies(ASource));
|
|
finally
|
|
UnlockCookieList(caReadWrite);
|
|
end;
|
|
end else
|
|
begin
|
|
inherited Assign(ASource);
|
|
end;
|
|
end;
|
|
|
|
function TIdCookies.GetCookie(Index: Integer): TIdCookie;
|
|
begin
|
|
Result := inherited GetItem(Index) as TIdCookie;
|
|
end;
|
|
|
|
procedure TIdCookies.SetCookie(Index: Integer; const Value: TIdCookie);
|
|
begin
|
|
inherited SetItem(Index, Value);
|
|
end;
|
|
|
|
function TIdCookies.AddClientCookie(const ACookie: string): TIdCookie;
|
|
var
|
|
LCookie: TIdCookie;
|
|
begin
|
|
Result := nil;
|
|
LCookie := Add;
|
|
try
|
|
if LCookie.ParseClientCookie(ACookie) then
|
|
begin
|
|
LockCookieList(caReadWrite);
|
|
try
|
|
FCookieList.Add(LCookie);
|
|
Result := LCookie;
|
|
LCookie := nil;
|
|
finally
|
|
UnlockCookieList(caReadWrite);
|
|
end;
|
|
end;
|
|
finally
|
|
if LCookie <> nil then
|
|
begin
|
|
LCookie.Collection := nil;
|
|
LCookie.Free;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TIdCookies.AddClientCookies(const ACookie: string);
|
|
var
|
|
Temp: TStringList;
|
|
LCookie, S: String;
|
|
I: Integer;
|
|
begin
|
|
S := Trim(ACookie);
|
|
if S <> '' then begin
|
|
Temp := TStringList.Create;
|
|
try
|
|
repeat
|
|
LCookie := Fetch(S, ';');
|
|
if LCookie <> '' then begin
|
|
Temp.Add(LCookie);
|
|
end;
|
|
until S = '';
|
|
for I := 0 to Temp.Count-1 do begin
|
|
AddClientCookie(Temp[I]);
|
|
end;
|
|
finally
|
|
Temp.Free;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TIdCookies.AddClientCookies(const ACookies: TStrings);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
for i := 0 to ACookies.Count - 1 do begin
|
|
AddClientCookies(ACookies[i]);
|
|
end;
|
|
end;
|
|
|
|
function TIdCookies.AddServerCookie(const ACookie: string; AURI: TIdURI): TIdCookie;
|
|
var
|
|
LCookie: TIdCookie;
|
|
begin
|
|
Result := nil;
|
|
LCookie := Add;
|
|
try
|
|
if LCookie.ParseServerCookie(ACookie, AURI) then begin
|
|
if AddCookie(LCookie, AURI) then
|
|
begin
|
|
Result := LCookie;
|
|
LCookie := nil;
|
|
end;
|
|
end;
|
|
finally
|
|
if LCookie <> nil then begin
|
|
LCookie.Collection := nil;
|
|
LCookie.Free;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TIdCookies.AddServerCookies(const ACookies: TStrings; AURI: TIdURI);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
for i := 0 to ACookies.Count - 1 do begin
|
|
AddServerCookie(ACookies[i], AURI);
|
|
end;
|
|
end;
|
|
|
|
procedure TIdCookies.AddCookies(ASource: TIdCookies);
|
|
var
|
|
LSrcCookies: TIdCookieList;
|
|
LSrcCookie, LDestCookie: TIdCookie;
|
|
i: Integer;
|
|
begin
|
|
if (ASource <> nil) and (ASource <> Self) then
|
|
begin
|
|
LSrcCookies := ASource.LockCookieList(caRead);
|
|
try
|
|
LockCookieList(caReadWrite);
|
|
try
|
|
for i := 0 to LSrcCookies.Count - 1 do
|
|
begin
|
|
LSrcCookie := LSrcCookies[i];
|
|
LDestCookie := TIdCookieClass(LSrcCookie.ClassType).Create(Self);
|
|
try
|
|
LDestCookie.Assign(LSrcCookie);
|
|
FCookieList.Add(LDestCookie);
|
|
except
|
|
LDestCookie.Collection := nil;
|
|
LDestCookie.Free;
|
|
raise;
|
|
end;
|
|
end;
|
|
finally
|
|
UnlockCookieList(caReadWrite);
|
|
end;
|
|
finally
|
|
ASource.UnlockCookieList(caRead);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TIdCookies.GetCookieByNameAndDomain(const AName, ADomain: string): TIdCookie;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
i := GetCookieIndex(AName, ADomain);
|
|
if i = -1 then begin
|
|
Result := nil;
|
|
end else begin
|
|
Result := Cookies[i];
|
|
end;
|
|
end;
|
|
|
|
function TIdCookies.GetCookieIndex(const AName: string; FirstIndex: Integer = 0): Integer;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
Result := -1;
|
|
for i := FirstIndex to Count - 1 do
|
|
begin
|
|
if TextIsSame(Cookies[i].CookieName, AName) then
|
|
begin
|
|
Result := i;
|
|
Exit;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TIdCookies.GetCookieIndex(const AName, ADomain: string; FirstIndex: Integer = 0): Integer;
|
|
var
|
|
LCookie: TIdCookie;
|
|
i: Integer;
|
|
begin
|
|
Result := -1;
|
|
for i := FirstIndex to Count - 1 do
|
|
begin
|
|
LCookie := Cookies[i];
|
|
if TextIsSame(LCookie.CookieName, AName) and
|
|
TextIsSame(CanonicalizeHostName(LCookie.Domain), CanonicalizeHostName(ADomain)) then
|
|
begin
|
|
Result := i;
|
|
Exit;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TIdCookies.Clear;
|
|
begin
|
|
LockCookieList(caReadWrite);
|
|
try
|
|
FCookieList.Clear;
|
|
inherited Clear;
|
|
finally
|
|
UnlockCookieList(caReadWrite);
|
|
end;
|
|
end;
|
|
|
|
function TIdCookies.LockCookieList(AAccessType: TIdCookieAccess): TIdCookieList;
|
|
begin
|
|
case AAccessType of
|
|
caRead:
|
|
begin
|
|
FRWLock.BeginRead;
|
|
end;
|
|
caReadWrite:
|
|
begin
|
|
FRWLock.BeginWrite;
|
|
end;
|
|
end;
|
|
Result := FCookieList;
|
|
end;
|
|
|
|
procedure TIdCookies.UnlockCookieList(AAccessType: TIdCookieAccess);
|
|
begin
|
|
case AAccessType of
|
|
caRead:
|
|
begin
|
|
FRWLock.EndRead;
|
|
end;
|
|
caReadWrite:
|
|
begin
|
|
FRWLock.EndWrite;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
end.
|