{
  Clever Internet Suite
  Copyright (C) 2013 Clever Components
  All Rights Reserved
  www.CleverComponents.com
}

unit clUriUtils;

interface

{$I clVer.inc}
{$IFDEF DELPHI6}
  {$WARN SYMBOL_PLATFORM OFF}
{$ENDIF}

uses
  clWUtils;

type
  TclUrlType = (utUnknown, utFTP, utGOPHER, utHTTP, utHTTPS, utFILE, utNEWS, utMAILTO);

  TclUrlParser = class
  private
    FScheme: string;
    FPath: string;
    FUserName: string;
    FQueryString: string;
    FHost: string;
    FPassword: string;
    FPort: Integer;
    FCharSet: string;
    FFragment: string;

    class function IsUnsafeChar(ACharCode: TclChar): Boolean;

    procedure ParseUrl(const AFullUrl: string);
    function BuildDomain: string;
    function BuildPath: string;
    function GetUrlType: TclUrlType;
    function GetDefaultPort(const AScheme: string): Integer;
    function NormalizePath(const APath: string): string;

    function GetAbsolutePath: string;
    function GetAbsoluteUri: string;
  public
    constructor Create; overload;
    constructor Create(const ACharSet: string); overload;

    class function EncodeUrl(const AUrl, ACharSet: string): string;

    procedure Clear;

    procedure Parse(const AFullUrl: string); overload;
    procedure Parse(const ABaseUrl, ARelativeUrl: string); overload;

    function GetURLByLocalFile(const AFullUrl, ALocalFile: string): string;
    function GetLocalFileByURL(const AFullUrl, ALocalFolder: string): string;

    procedure Assign(Source: TclUrlParser); virtual;

    property CharSet: string read FCharSet write FCharSet;

    property Scheme: string read FScheme write FScheme;
    property Host: string read FHost write FHost;
    property UserName: string read FUserName write FUserName;
    property Password: string read FPassword write FPassword;
    property Path: string read FPath write FPath;
    property QueryString: string read FQueryString write FQueryString;
    property Fragment: string read FFragment write FFragment;
    property Port: Integer read FPort write FPort;

    property UrlType: TclUrlType read GetUrlType;
    property AbsolutePath: string read GetAbsolutePath;
    property AbsoluteUri: string read GetAbsoluteUri;
  end;

implementation

uses
{$IFNDEF DELPHIXE2}
  Classes, SysUtils, Windows,
{$ELSE}
  System.Classes, System.SysUtils, Winapi.Windows,
{$ENDIF}
  clUtils, clIdnTranslator, clTranslator{$IFDEF DELPHIXE4}, System.AnsiStrings{$ENDIF};

var
  UnsafeUriChars: PclChar = nil;
  UnsafeUriCharsCount: Integer = 0;

{$IFDEF DELPHIXE4}
function StrLen(A: PclChar): Integer;
begin
  Result := System.AnsiStrings.StrLen(A);
end;
{$ENDIF}

procedure InitStaticVars;
const
  Chars = ' <>"#%{}|\^~[]`';
begin
  UnsafeUriCharsCount := TclTranslator.GetByteCount(Chars, 'us-ascii');
  if (UnsafeUriCharsCount > 0) then
  begin
    GetMem(UnsafeUriChars, UnsafeUriCharsCount + 1);
    try
      TclTranslator.GetBytes(Chars, UnsafeUriChars, UnsafeUriCharsCount + 1, 'us-ascii');
      UnsafeUriChars[UnsafeUriCharsCount] := #0;
    except
      FreeMem(UnsafeUriChars);
      UnsafeUriChars := nil;
      UnsafeUriCharsCount := 0;
    end;
  end;
end;

{ TclUrlParser }

class function TclUrlParser.EncodeUrl(const AUrl, ACharSet: string): string;
  function IsHexDigit(c: TclChar): Boolean;
  begin
    Result := (c in ['0'..'9']) or (c in ['a'..'f']) or (c in ['A'..'F']);
  end;

var
  i, size: Integer;
  encBytes: PclChar;
begin
  Result := '';

  size := TclTranslator.GetByteCount(AUrl, ACharSet);
  if (size > 0) then
  begin
    GetMem(encBytes, size);
    try
      TclTranslator.GetBytes(AUrl, encBytes, size, ACharSet);

      i := 0;
      while (i < size) do
      begin
        if (encBytes[i] = '%') and (i + 2 < size)
          and IsHexDigit(encBytes[i + 1]) and IsHexDigit(encBytes[i + 2]) then
        begin
          Result := Result + '%' + string(encBytes[i + 1]) + string(encBytes[i + 2]);
          Inc(i, 2);
        end else
        if IsUnsafeChar(encBytes[i]) or (encBytes[i] >= #$7F) or (encBytes[i] < #$20) then
        begin
          Result := Result + '%' + IntToHex(Integer(encBytes[i]), 2);
        end else
        begin
          Result := Result + string(encBytes[i]);
        end;
        Inc(i);
      end;
    finally
      FreeMem(encBytes);
    end;
  end else
  begin
    Result := StringReplace(Trim(AUrl), #32, '%20', [rfReplaceAll]);
  end;
end;

procedure TclUrlParser.Parse(const AFullUrl: string);
begin
  ParseUrl(AFullUrl);

  if (Scheme = '') and (Host <> '') then
  begin
    Scheme := 'http';
  end;

  if (Port = 0) then
  begin
    Port := GetDefaultPort(Scheme);
  end;
end;

function TclUrlParser.GetURLByLocalFile(const AFullUrl, ALocalFile: string): string;
var
  ind: Integer;
begin
  Parse(AFullUrl);

  Result := Path;
  ind := LastDelimiter('/', Result);
  Result := system.Copy(Result, 1, ind);
  ind := Length(Result);
  if (ind > 0) and (Result[ind] <> '/') then
  begin
    Result := Result + '/';
  end;
  ind := LastDelimiter('\', ALocalFile);
  Result := Result + system.Copy(ALocalFile, ind + 1, MaxInt);

  Path := Result;

  Result := AbsoluteUri;
end;

function TclUrlParser.GetUrlType: TclUrlType;
begin
  if (Scheme = 'ftp') then
  begin
    Result := utFTP;
  end else
  if (Scheme = 'gopher') then
  begin
    Result := utGOPHER;
  end else
  if (Scheme = 'http') then
  begin
    Result := utHTTP;
  end else
  if (Scheme = 'https') then
  begin
    Result := utHTTPS;
  end else
  if (Scheme = 'file') then
  begin
    Result := utFILE;
  end else
  if (Scheme = 'news') then
  begin
    Result := utNEWS;
  end else
  if (Scheme = 'mailto') then
  begin
    Result := utMAILTO;
  end else
  begin
    Result := utUnknown;
  end;
end;

function TclUrlParser.GetDefaultPort(const AScheme: string): Integer;
begin
  if (AScheme = 'ftp') then
  begin
    Result := 21;
  end else
  if (AScheme = 'gopher') then
  begin
    Result := 70;
  end else
  if (AScheme = 'http') then
  begin
    Result := 80;
  end else
  if (AScheme = 'https') then
  begin
    Result := 443;
  end else
  begin
    Result := 0;
  end;
end;

function TclUrlParser.GetLocalFileByURL(const AFullUrl, ALocalFolder: string): string;
var
  ind: Integer;
begin
  Result := ALocalFolder;
  Parse(AFullUrl);
  if (AbsoluteUri <> '') then
  begin
    Result := AddTrailingBackSlash(Result);
    ind := LastDelimiter('/', Path);
    Result := Result + system.Copy(Path, ind + 1, MaxInt);
  end;
end;

procedure TclUrlParser.ParseUrl(const AFullUrl: string);
const
  mailto = 'mailto:';
var
  ind: Integer;
  s: string;
begin
  Clear();

  s := AFullUrl;

  ind := Pos('#', s);
  if (ind > 0) then
  begin
    Fragment := Copy(s, ind, MaxInt);
    s := Copy(s, 1, ind - 1);
  end;

  ind := Pos('?', s);
  if (ind > 0) then
  begin
    QueryString := Copy(s, ind, MaxInt);
    s := Copy(s, 1, ind - 1);
  end;

  ind := Pos('://', s);
  if (ind > 0) then
  begin
    Scheme := LowerCase(Copy(s, 1, ind - 1));
    s := Copy(s, ind + Length('://'), MaxInt);
  end else
  if (Length(s) >= Length(mailto))
    and (mailto = LowerCase(Copy(s, 1, Length(mailto)))) then
  begin
    Scheme := 'mailto';
    s := Copy(s, Length(mailto) + 1, MaxInt);
  end;

  ind := Pos('/', s);
  if (ind > 0) then
  begin
    if (ind > 1) and (s[ind - 1] = '.') then
    begin
      Dec(ind);
    end;
    if (ind > 1) and (s[ind - 1] = '.') then
    begin
      Dec(ind);
    end;

    Path := Copy(s, ind, MaxInt);
    s := Copy(s, 1, ind - 1);
  end;

  ind := Pos('@', s);
  if (ind > 0) then
  begin
    UserName := Copy(s, 1, ind - 1);
    s := Copy(s, ind + Length('@'), MaxInt);

    ind := Pos(':', UserName);
    if (ind > 0) then
    begin
      Password := Copy(UserName, ind + Length(':'), MaxInt);
      UserName := Copy(UserName, 1, ind - 1);
    end;
  end;

  ind := Pos(':', s);
  if (ind > 0) then
  begin
    Port := StrToIntDef(Copy(s, ind + Length(':'), MaxInt), Port);
    s := Copy(s, 1, ind - 1);
  end;
  Host := s;
end;

function TclUrlParser.BuildDomain: string;
begin
  Result := '';

  if (LowerCase(Scheme) = 'mailto') then
  begin
    Result := Result + Scheme + ':';
  end else
  if (Scheme <> '') then
  begin
    Result := Result + Scheme + '://';
  end;

  if (Host <> '') then
  begin
    if (UserName <> '') then
    begin
      Result := Result + UserName;
      if (Password <> '') then
      begin
        Result := Result + ':' + Password;
      end;
      Result := Result + '@';
    end;

    Result := Result + TclIdnTranslator.GetAscii(Host);
  end;

  if (Port <> 0) and (GetDefaultPort(Scheme) <> Port) then
  begin
    Result := Result + ':' + IntToStr(Port);
  end;

  Result := Result;
end;

function TclUrlParser.BuildPath: string;
var
  s: string;
begin
  Result := '';

  if ((Host <> '') and (Path = '') and (LowerCase(Scheme) <> 'mailto'))
    or ((Path <> '') and (Path[1] <> '/')) then
  begin
    Result := Result + '/';
  end;
  Result := Result + Path;

  if (QueryString <> '') and (QueryString[1] <> '?') then
  begin
    Result := Result + '?';
  end;
  Result := EncodeUrl(Result + QueryString, FCharSet);

  s := Fragment;
  if (s <> '') then
  begin
    if (s[1] = '#') then
    begin
      Delete(s, 1, 1);
    end;
    s := '#' + EncodeUrl(s, FCharSet);
  end;
  Result := Result + s;
end;

constructor TclUrlParser.Create(const ACharSet: string);
begin
  inherited Create();

  Clear();
  FCharSet := ACharSet;
end;

class function TclUrlParser.IsUnsafeChar(ACharCode: TclChar): Boolean;
var
  i: Integer;
begin
  for i := 0 to UnsafeUriCharsCount - 1 do
  begin
    if (UnsafeUriChars[i] = ACharCode) then
    begin
      Result := True;
      Exit;
    end;
  end;
  Result := False;
end;

function TclUrlParser.NormalizePath(const APath: string): string;
var
  i, ind: Integer;
  parts: TStrings;
begin
  Result := APath;
  parts := TStringList.Create();
  try
    ind := Pos('/', Result);
    while (ind > 0) do
    begin
      parts.Add(Copy(Result, 1, ind - 1));

      Result := Copy(Result, ind + 1, Length(Result) - ind);
      ind := Pos('/', Result);
    end;

    parts.Add(Result);
    if (Result = '..') or (Result = '.') then
    begin
      parts.Add('');
    end;

    ind := parts.IndexOf('.');
    while (ind > -1) do
    begin
      parts.Delete(ind);
      ind := parts.IndexOf('.');
    end;

    ind := parts.IndexOf('..');
    while (ind > 0) do
    begin
      parts.Delete(ind);
      parts.Delete(ind - 1);
      ind := parts.IndexOf('..');
    end;

    Result := '';

    if (parts.Count = 0) or (parts[0] <> '..') then
    begin
      for i := 0 to parts.Count - 1 do
      begin
        Result := Result + '/' + parts[I];
      end;
    end;
  finally
    parts.Free();
  end;
end;

procedure TclUrlParser.Clear;
begin
  Scheme := '';
  Host := '';
  UserName := '';
  Password := '';
  Path := '';
  QueryString := '';
  Fragment := '';
  Port := 0;
end;

constructor TclUrlParser.Create;
begin
  Create('');
end;

procedure TclUrlParser.Parse(const ABaseUrl, ARelativeUrl: string);
var
  baseParser: TclUrlParser;
  ind: Integer;
  s: string;
begin
  if (ABaseUrl = '') and (ARelativeUrl = '') then
  begin
    Clear();
    Exit;
  end;

  baseParser := TclUrlParser.Create(CharSet);
  try
    baseParser.ParseUrl(ABaseUrl);
    ParseUrl(ARelativeUrl);

    if (baseParser.Scheme <> '') and (Scheme = '') and (Host <> '') then
    begin
      if (Length(Path) > 0) and (Path[1] <> '/') then
      begin
        Path := '/' + Path;
      end;
      Path := Host + Path;
      Host := '';
    end;

    if (Scheme = '') and (baseParser.Scheme <> '') then
    begin
      Scheme := baseParser.Scheme;
      Host := baseParser.Host;
      UserName := baseParser.UserName;
      Password := baseParser.Password;
    end;

    if (Scheme = '') and (Host <> '') then
    begin
      Scheme := 'http';
    end;

    if (Length(Path) > 0) and (Path[1] = '/') then
    begin
      s := Copy(Path, 2, MaxInt);
    end else
    begin
      ind := LastDelimiter('/', baseParser.Path);
      if (ind > 0) then
      begin
        s := Copy(baseParser.Path, 2, ind - 1)
      end else
      begin
        s := '';
      end;

      s := s + Path;
    end;

    Path := NormalizePath(s);

    if (Scheme = '') and (Host = '') and (Path = '') and (s <> '') then
    begin
      Path := s;
    end;

    if (Port = 0) then
    begin
      Port := GetDefaultPort(Scheme);
    end;
  finally
    baseParser.Free();
  end;
end;

procedure TclUrlParser.Assign(Source: TclUrlParser);
begin
  Scheme := Source.Scheme;
  Host := Source.Host;
  UserName := Source.UserName;
  Password := Source.Password;
  Path := Source.Path;
  QueryString := Source.QueryString;
  Fragment := Source.Fragment;
  Port := Source.Port;
end;

function TclUrlParser.GetAbsolutePath: string;
begin
  if (Host = '*') then
  begin
    Result := Host;
  end else
  begin
    Result := BuildPath();
  end;
end;

function TclUrlParser.GetAbsoluteUri: string;
begin
  Result := BuildDomain() + BuildPath();
end;

initialization
  InitStaticVars();

finalization
  FreeMem(UnsafeUriChars);

end.

