alhttpcommon.pas

Description: common http function that can be use by HTTP Component

    property Warning: String read FWarning; {Warning: 112 Disconnected Operation}
    property WWWAuthenticate: String read FWWWAuthenticate; {WWW-Authenticate: [challenge]}
    Property CustomHeaders: Tstrings read FCustomHeaders;
    property Cookies: TStrings read FCookies;
    property StatusCode: String read FStatusCode;
    property HttpProtocolVersion: String read FHttpProtocolVersion;
    Property ReasonPhrase: String read FReasonPhrase;
    property RawHeaderText: String read GetRawHeaderText write setRawHeaderText;
  end;

{Http Function}
function  ALHTTPDecode(const AStr: String): string;
function  ALHTTPEncodeParam(const AStr: String): string;
procedure ALHTTPEncodeParamNameValues(ParamValues: TStrings);
procedure ALExtractHTTPFields(Separators, WhiteSpace: TSysCharSet; Content: PChar; Strings: TStrings; StripQuotes: Boolean = False);
Function  AlExtractShemeFromUrl(aUrl: String): TInternetScheme;
Function  AlExtractHostNameFromUrl(aUrl: String): String;
Function  AlRemoveAnchorFromUrl(aUrl: String; Var aAnchor: String): String; overload;
Function  AlRemoveAnchorFromUrl(aUrl: String): String; overload;
function  AlCombineUrl(RelativeUrl, BaseUrl: String): String;


ResourceString
  CALHTTPCLient_MsgInvalidURL         = 'Invalid url ''%s'' - only supports ''http'' and ''https'' schemes';
  CALHTTPCLient_MsgInvalidHTTPRequest = 'Invalid HTTP Request: Length is 0';
  CALHTTPCLient_MsgEmptyURL           = 'Empty URL';

implementation

uses HTTPapp,
     alFcnRFC,
     AlFcnString;

{***********************************************************************}
function AlStringFetch(var AInput: string; const ADelim: string): string;
var
  LPos: Integer;
begin
  LPos := AlPos(ADelim, AInput);
  if LPos = 0 then begin
    Result := AInput;
    AInput := '';
  end
  else begin
    Result := AlCopyStr(AInput, 1, LPos - 1);
    AInput := AlCopyStr(AInput, LPos + Length(ADelim), MaxInt);
  end;
end;


/////////////////////////////////////////////////////////////////////////////
////////// TALHTTPRequestCookie /////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////

{***************************************************************}
constructor TALHTTPRequestCookie.Create(Collection: TCollection);
begin
  inherited Create(Collection);
  FExpires := -1;
  FSecure := False;
end;

{*********************************************************}
procedure TALHTTPRequestCookie.AssignTo(Dest: TPersistent);
begin
  if Dest is TALHTTPRequestCookie then
    with TALHTTPRequestCookie(Dest) do begin
      Name := Self.FName;
      Value := Self.FValue;
      Domain := Self.FDomain;
      Path := Self.FPath;
      Expires := Self.FExpires;
      Secure := Self.FSecure;
    end
    else inherited AssignTo(Dest);
end;

{***************************************************}
function TALHTTPRequestCookie.GetHeaderValue: string;
var aYear, aMonth, aDay: Word;
begin
  Result := Format('%s=%s; ', [ALHTTPEncodeParam(FName), ALHTTPEncodeParam(FValue)]);
  if Domain <> '' then Result := Result + Format('domain=%s; ', [Domain]);
  if Path <> '' then Result := Result + Format('path=%s; ', [Path]);
  if Expires > -1 then begin
    DecodeDate(Expires, aYear, aMonth, aDay);
    Result := Result + Format(
                              FormatDateTime(
                                             '"expires=%s, "dd"-%s-"yyyy" "hh":"nn":"ss" GMT; "',
                                             Expires
                                            ),
                              [
                               CAlRfc822DaysOfWeek[DayOfWeek(Expires)],
                               CAlRfc822MonthNames[aMonth]
                              ]
                             );
  end;
  if Secure then Result := Result + 'secure';
  if Copy(Result, Length(Result) - 1, MaxInt) = '; ' then SetLength(Result, Length(Result) - 2);
end;

{******************************************************************}
procedure TALHTTPRequestCookie.SetHeaderValue(Const aValue: string);
Var aCookieProp: TStringList;
    aCookieStr: String;
begin
  FName:= '';
  FValue:= '';
  FPath:= '';
  FDomain:= '';
  FExpires:= -1;
  FSecure:= False;

  aCookieProp := TStringList.Create;
  try
    aCookieStr := AValue;

    while Pos(';', aCookieStr) > 0 do begin
      aCookieProp.Add(Trim(AlStringFetch(aCookieStr, ';')));
      if (Pos(';', aCookieStr) = 0) and (Length(aCookieStr) > 0) then aCookieProp.Add(Trim(aCookieStr));
    end;

    if aCookieProp.Count = 0 then aCookieProp.Text := aCookieStr;
    if aCookieProp.Count = 0 then exit;

    FName := aCookieProp.Names[0];
    FValue := aCookieProp.Values[aCookieProp.Names[0]];
    aCookieProp.Delete(0);

    FPath := aCookieProp.values['PATH'];
    { Tomcat can return SetCookie2 with path wrapped in " }
    if (Length(FPath) > 0) then begin
      if FPath[1] = '"' then Delete(FPath, 1, 1);
      if FPath[Length(FPath)] = '"' then SetLength(FPath, Length(FPath) - 1);
    end
    else FPath := '/';
    if not ALTryRfc822StrToGmtDateTime(aCookieProp.values['EXPIRES'], FExpires) then FExpires := -1;
    FDomain := aCookieProp.values['DOMAIN'];
    FSecure := aCookieProp.IndexOf('SECURE') <> -1;
  finally
    aCookieProp.free;
  end;
end;



/////////////////////////////////////////////////////////////////////////////
////////// TCookieCollection ////////////////////////////////////////////////
/////////////////////////////////////////////////////////////////////////////

{****************************************************************}
function TALHTTPRequestCookieCollection.Add: TALHTTPRequestCookie;
begin
  Result := TALHTTPRequestCookie(inherited Add);
end;

{**************************************************************************************}
function TALHTTPRequestCookieCollection.GetCookie(Index: Integer): TALHTTPRequestCookie;
begin
  Result := TALHTTPRequestCookie(inherited Items[Index]);
end;

{***********************************************************************************************}
procedure TALHTTPRequestCookieCollection.SetCookie(Index: Integer; Cookie: TALHTTPRequestCookie);
begin
  Items[Index].Assign(Cookie);
end;




///////////////////////////////////////////////////////////////////////////////////////
////////// TALHTTPClientResponseHeader ////////////////////////////////////////////////
///////////////////////////////////////////////////////////////////////////////////////

{***************************************}
constructor TALHTTPResponseHeader.Create;
begin
  inherited;
  FCustomHeaders := TstringList.create;
  FCustomHeaders.Delimiter := ':';
  FCookies := TstringList.create;
  clear;
end;

{***************************************}
destructor TALHTTPResponseHeader.Destroy;
begin
  FCustomHeaders.free;
  FCookies.free;
  inherited;
end;

{************************************}
procedure TALHTTPResponseHeader.Clear;
begin
  FAcceptRanges:= '';
  FAge:= '';
  FAllow:= '';
  FCacheControl:= '';
  FConnection:= '';
  FContentEncoding:= '';
  FContentLanguage:= '';
  FContentLength:= '';
  FContentLocation:= '';
  FContentMD5:= '';
  FContentRange:= '';
  FContentType:= '';
  FDate:= '';
  FETag:= '';
  FExpires:= '';
  FLastModified:= '';
  FLocation:= '';
  FPragma:= '';
  FProxyAuthenticate:= '';
  FRetryAfter:= '';
  FServer:= '';
  FTrailer:= '';
  FTransferEncoding:= '';
  FUpgrade:= '';
  FVary:= '';
  FVia:= '';
  FWarning:= '';
  FWWWAuthenticate:= '';
  FRawHeaderText:= '';
  FCustomHeaders.clear;
  FCookies.Clear;
  FStatusCode:= '';
  FHttpProtocolVersion:= '';
  FReasonPhrase := '';
end;

{******************************************************}
function TALHTTPResponseHeader.GetRawHeaderText: String;
begin
  result := FRawHeaderText;
end;

{*****************************************************************************}
procedure TALHTTPResponseHeader.SetRawHeaderText(Const aRawHeaderText: string);
Var aRawHeaderLst: TstringList;
    j: integer;
    AStatusLine: String;

  {-------------------------------------}
  Function AlG001(aName: String): String;
  Var i: Integer;
  bFound: boolean;
  index: integer;
  Begin
    result := '';
    bFound:= false;
    for i:= 0 to aRawHeaderLst.Count - 1 do
    begin
      index := pos(aname, aRawHeaderLst[i]);
      if index = 1 then
      begin
        bFound := true;
        break;
      end;
    end;

    if bFound then
    begin
      result := copy(aRawHeaderLst[i], index + Length(aName) + 1, Length(aRawHeaderLst[i]));
      result := trim(result);
      aRawHeaderLst.Delete(i);
    end;
    {
    I := aRawHeaderLst.IndexOfName(aName);
    If I >= 0 then Begin
      result := Trim(aRawHeaderLst.Values[aName]);
      aRawHeaderLst.Delete(i);
    end
    else result := '';
    }
  end;

begin
  aRawHeaderLst := TstringList.create;
  try
    aRawHeaderLst.Delimiter := ':';
    aRawHeaderLst.Text := aRawHeaderText;

    FAcceptRanges := Alg001('Accept-Ranges');
    FAge:= Alg001('Age');
    FAllow := Alg001('Allow');
    FCacheControl := Alg001('Cache-Control');
    FConnection := Alg001('Connection');
    FContentEncoding := Alg001('Content-Encoding');
    FContentLanguage := Alg001('Content-Language');
    FContentLength := Alg001('Content-Length');
    FContentLocation := Alg001('Content-Location');
    FContentMD5 := Alg001('Content-MD5');
    FContentRange := Alg001('Content-Range');