restemplate/indy/Protocols/IdCookie.pas

{
  $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.