unit Sparkle.Utils;

{$I Sparkle.Inc}

interface

uses
  Generics.Collections, SysUtils;

type
  TNameValuePair = record
    Name: string;
    Value: string;
    constructor Create(const AName, AValue: string);
  end;

  THeaderParamsInfo = record
    Value: string;
    Params: TArray<TNameValuePair>;
    function ParamValue(const Name: string): string;
    function TryParamValue(const Name: string; var Value: string): Boolean;
  end;

  TContentTypeInfo = THeaderParamsInfo;
  TContentDispositionInfo = THeaderParamsInfo;

  TSparkleUtils = class
  private
    class var FISODateSettings: TFormatSettings;
    class function ParseHeaderParams(const Header: string): THeaderParamsInfo;
    class procedure ExtractNameValue(const S: string; Separator: Char; var Name, Value: string);
  public
    class constructor Create;
    class function DateTimeToISO(const Value: TDateTime; FullNotation: boolean): string; static;
    class function ISOToDateTime(const Value: string): TDateTime; static;
    class function TryISOToDateTime(const Value: string; out DateTime: TDateTime): boolean; static;
    class function TimeToISO(const Value: TTime): string; static;
    class function ISOToTime(const Value: string): TTime; static;
    class function TryISOToTime(const Value: string; out DateTime: TTime): boolean; static;
    class function DateToISO(const Value: TDate): string; static;
    class function ISOToDate(const Value: string): TDate; static;
    class function TryISOToDate(const Value: string; out DateTime: TDate): boolean; static;
    class function EncodeBase64(const Input: TBytes): string; static;
    class function DecodeBase64(const Input: string): TBytes; static;
    class function DateTimeToDayTimeDuration(const Value: TTime): string; static;
    class function TryDayTimeDurationToDateTime(const Value: string; out Time: TTime): boolean; static;
    class function TryStringToGuid(const Value: string; out Guid: TGuid): boolean; static;
    class function CombineUrlFast(const AbsoluteUrl, RelativeUrl: string): string; static;
    class function LocalDateTimeToUnix(const Value: TDateTime): Int64; static;
    class function DateTimeToJson(const Value: TDateTime): string; static;
    class function GetStatusReason(const StatusCode: integer): string;
    class function BasicAuthHeaderValue(const UserName, Password: string): string; static;
    class procedure GetNameAndAnnotation(const Text: string; out AName, AAnnotation: string); static;

    class function PercentEncode(const S: string): string; overload; static;
    class function PercentEncode(Segments: TArray<string>): string; overload; static;
    class function PercentDecode(const S: string): string; static;

    class function GetQueryParams(const Query: string;
      DecodePlus: Boolean = False): TArray<TPair<string, string>>;

    class function AcceptsType(const Accept: string; const Value: string): boolean; overload;
    class function AcceptsType(const Accept: string; const Values: TArray<string>): string; overload;

    class function ParseContentType(const Value: string): TContentTypeInfo;
    class function ParseContentDisposition(const Value: string): TContentDispositionInfo;
    class procedure ParseHeader(const Header: string; var Name, Value: string);

    class function AcceptsEncoding(const Accept: string; const Value: string): boolean; overload;
    class function AcceptsEncoding(const Accept: string; const Values: TArray<string>): string; overload;
  end;

implementation

uses
  System.Types, System.StrUtils, System.Character, System.DateUtils,
  Bcl.Utils;

{ TSparkleUtils }

const
  SInvalidDateFormat = 'Value %s is not a valid datetime';

type
  TAcceptItem = record
    TypeName: string;
    SubType: string;
    Q: double;
  end;

  TMatchWeight = record
    Value: integer;
    Q: double;
    TypeName: string;
  end;

function ParseMediaItem(const Item: string): TAcceptItem;
var
  Parts: TStringDynArray;
  Param, ParamName, ParamValue: string;
  QValue: double;
  I: integer;
  P: integer;
  FullType: string;
begin
  Parts := SplitString(Trim(Item), ';');

  // parse params
  Result.Q := 1;
  for I := 1 to Length(Parts) - 1 do
  begin
    Param := Parts[I];
    P := Pos('=', Param);
    if P > 0 then
    begin
      ParamName := Copy(Param, 1, P - 1);
      ParamValue := Copy(Param, P + 1, MaxInt);
      if ParamName = 'q' then
      begin
        // ignore other parameters for now
        if not TryStrToFloat(ParamValue, QValue, TSparkleUtils.FISODateSettings) or (QValue < 0) or (QValue > 1) then
          QValue := 1;
        Result.Q := QValue;
      end;
    end;
  end;

  if Length(Parts) > 0 then
    FullType := Parts[0]
  else
    FullType := '*/*';
  if FullType = '*' then
    FullType := '*/*';

  P := Pos('/', FullType);
  if P > 0 then
  begin
    Result.TypeName := Copy(FullType, 1, P - 1);
    Result.SubType := Copy(FullType, P + 1, MaxInt);
  end
  else
  begin
    Result.TypeName := FullType;
    Result.SubType := '*';
  end;
end;

function MediaItemWeight(const Item: string; Acceptables: TArray<TAcceptItem>): TMatchWeight;
var
  Target: TAcceptItem;
  Acceptable: TAcceptItem;
  EqualsType, EqualsSubType: boolean;
  TempWeight: integer;
begin
  Target := ParseMediaItem(Item);
  Result.Value := -1;
  Result.Q := 0;

  for Acceptable in Acceptables do
  begin
    EqualsType := SameText(Target.TypeName, Acceptable.TypeName);
    EqualsSubType := SameText(Target.SubType, Acceptable.SubType);
    if (EqualsType or (Acceptable.TypeName = '*') or (Target.TypeName = '*'))
      and
      (EqualsSubType or (Acceptable.SubType = '*') or (Target.SubType = '*')) then
    begin
      TempWeight := 0;
      if EqualsType then
        TempWeight := TempWeight + 100;
      if EqualsSubType then
        TempWeight := TempWeight + 10;
      if (TempWeight > Result.Value) then
      begin
        Result.Value := TempWeight;
        Result.Q := Acceptable.Q;
      end;
    end;
  end;
end;

function GetAcceptables(const Accept: string): TArray<TAcceptItem>;
var
  MediaItems: TStringDynArray;
  I: integer;
begin
  MediaItems := SplitString(Accept, ',');
  SetLength(Result, Length(MediaItems));
  for I := 0 to Length(MediaItems) - 1 do
    Result[I] := ParseMediaItem(MediaItems[I]);
end;

function BestAcceptableMatch(Acceptables: TArray<TAcceptItem>; Values: TArray<string>): TMatchWeight;
var
  Weight: TMatchWeight;
  I: integer;
begin
  Result.Value := -1;
  Result.Q := 0;
  for I := 0 to Length(Values) - 1 do
  begin
    Weight := MediaItemWeight(Values[I], Acceptables);
    if Weight.Value = -1 then Continue;

    if (Weight.Value > Result.Value) or
      ((Weight.Value = Result.Value) and (Weight.Q > Result.Q)) or
      (Result.Q = 0) then
    begin
      Result := Weight;
      Result.TypeName := Values[I];
    end;
  end;
//  if Result.Q > 0 then
//    Result := '';
end;

class function TSparkleUtils.AcceptsType(const Accept: string; const Value: string): boolean;
begin
  Result := AcceptsType(Accept, TArray<string>.Create(Value)) <> '';
end;

class function TSparkleUtils.AcceptsType(const Accept: string; const Values: TArray<string>): string;
var
  Acceptables: TArray<TAcceptItem>;
  Match: TMatchWeight;
begin
  if Length(Values) = 0 then Exit('');
  if Accept = '' then Exit(Values[0]);

  Acceptables := GetAcceptables(Accept);

  Match := BestAcceptableMatch(Acceptables, Values);
  if Match.Q > 0 then
    Result := Match.TypeName
  else
    Result := '';
end;

class function TSparkleUtils.AcceptsEncoding(const Accept: string; const Value: string): boolean;
begin
  Result := AcceptsType(Accept, TArray<string>.Create(Value)) <> '';
end;

class function TSparkleUtils.AcceptsEncoding(const Accept: string; const Values: TArray<string>): string;
var
  Acceptables: TArray<TAcceptItem>;
  Acceptable: TAcceptItem;
  HasIdentity: boolean;
  Value: string;
  Match: TMatchWeight;
begin
  if Length(Values) = 0 then Exit('');
//  if Accept = '' then Exit(Values[0]); // we must consider identity

  HasIdentity := false;
  Acceptables := GetAcceptables(Accept);
  for Acceptable in Acceptables do
  begin
    if not HasIdentity and SameText(Acceptable.TypeName, 'identity') then
      HasIdentity := True;
  end;

  Match := BestAcceptableMatch(Acceptables, Values);
  if Match.Q > 0 then
    Exit(Match.TypeName);

  // check for identity
  if not HasIdentity and not SameText(Match.TypeName, 'identity') then
    for Value in Values do 
      if SameText(Value, 'identity') then
        Exit(Value);
end;

class function TSparkleUtils.BasicAuthHeaderValue(const UserName, Password: string): string;
begin
  Result := 'Basic ' + EncodeBase64(TEncoding.UTF8.GetBytes(Format('%s:%s', [UserName, Password])));
end;

class function TSparkleUtils.CombineUrlFast(const AbsoluteUrl,
  RelativeUrl: string): string;
begin
  Result := TBclUtils.CombineUrlFast(AbsoluteUrl, RelativeUrl);
end;

class constructor TSparkleUtils.Create;
begin
  FISODateSettings.ShortDateFormat := 'YYYY-mm-dd';
  FISODateSettings.DateSeparator := '-';
  FISODateSettings.ShortTimeFormat := 'hh:nn:ss.zzz';
  FISODateSettings.TimeSeparator := ':';
  FISODateSettings.DecimalSeparator := '.';
  FISODateSettings.TimeAMString := 'AM';
  FISODateSettings.TimePMString := 'PM';
end;

class function TSparkleUtils.DateTimeToDayTimeDuration(
  const Value: TTime): string;
var
  D, H, M, S, MS: Word;
begin
  D := Trunc(Value);
  DecodeTime(Value, H, M, S, MS);
  Result := 'P';
  if D > 0 then
    Result := Result + IntToStr(D) + 'D';
  if H > 0 then
    Result := Result + IntToStr(H) + 'H';
  if M > 0 then
    Result := Result + IntToStr(M) + 'M';
  if S > 0 then
    Result := Result + IntToStr(S) + 'S';
  if Result = 'P' then
    Result := 'P0D';
end;

class function TSparkleUtils.DateTimeToISO(const Value: TDateTime; FullNotation: boolean): string;
begin
  Result := TBclUtils.DateTimeToIso(Value, FullNotation);
end;

class function TSparkleUtils.DateTimeToJson(const Value: TDateTime): string;
begin
  Result := Format('\/Date(%d)\/', [LocalDateTimeToUnix(Value) * 1000]);
end;

class function TSparkleUtils.LocalDateTimeToUnix(const Value: TDateTime): Int64;
begin
  Result := Round((Value - UnixDateDelta) * SecsPerDay);
end;

class function TSparkleUtils.DecodeBase64(const Input: string): TBytes;
begin
  Result := TBclUtils.DecodeBase64(Input);
end;

class function TSparkleUtils.EncodeBase64(const Input: TBytes): string;
begin
  Result := TBclUtils.EncodeBase64(Input);
end;

class procedure TSparkleUtils.ExtractNameValue(const S: string; Separator: Char;
  var Name, Value: string);
var
  P: Integer;
begin
  P := Pos(Separator, S);
  if P > 1 then
  begin
    Name := Copy(S, 1, P - 1);
    Value := Copy(S, P + 1);
  end
  else
  begin
    Name := '';
    Value := S;
  end;
end;

class procedure TSparkleUtils.GetNameAndAnnotation(const Text: string; out AName,
  AAnnotation: string);
var
  P: integer;
begin
  P := Pos('@', Text);
  if P = 0 then
  begin
    AName := Text;
    AAnnotation := '';
  end else
  begin
    AName := Copy(Text, 1, P - 1);
    AAnnotation := Copy(Text, P + 1, MaxInt);
  end;
end;

class function TSparkleUtils.GetQueryParams(const Query: string;
  DecodePlus: Boolean = False): TArray<TPair<string, string>>;

  function _Decode(const S: string): string;
  begin
    if DecodePlus then
      Result := TSparkleUtils.PercentDecode(StringReplace(S, '+', '%20', [rfReplaceAll]))
    else
      Result := TSparkleUtils.PercentDecode(S);
  end;

var
  QueryItem: string;
  QueryItems: TStringDynArray;
  I, P: integer;
  Name, Value: string;
begin
  if (Length(Query) > 0) and (Query[1] = '?') then
    QueryItems := SplitString(Copy(Query, 2, MaxInt), '&')
  else
    QueryItems := SplitString(Query, '&');
  SetLength(Result, Length(QueryItems));
  for I := 0 to Length(QueryItems) - 1 do
  begin
    QueryItem := QueryItems[I];
    P := Pos('=', QueryItem);
    Name := Copy(QueryItem, 1, P - 1);
    Value := Copy(QueryItem, P + 1, MaxInt);
    Name := _Decode(Name);
    Value := _Decode(Value);
    Result[I].Key := Name;
    Result[I].Value := Value;
  end;
end;

class function TSparkleUtils.GetStatusReason(const StatusCode: integer): string;
begin
  case StatusCode of
    100: Result := 'Continue';
    101: Result := 'Switching Protocols';
    102: Result := 'Processing';
    200: Result := 'OK';
    201: Result := 'Created';
    202: Result := 'Accepted';
    203: Result := 'Non-Authoritative Information';
    204: Result := 'No Content';
    205: Result := 'Reset Content';
    206: Result := 'Partial Content';
    207: Result := 'Multi-Status';
    208: Result := 'Already Reported';
    300: Result := 'Multiple Choices';
    301: Result := 'Moved Permanently';
    302: Result := 'Found';
    303: Result := 'See Other';
    304: Result := 'Not Modified';
    305: Result := 'Use Proxy';
    306: Result := 'Switch Proxy';
    307: Result := 'Temporary Redirect';
    400: Result := 'Bad Request';
    401: Result := 'Unauthorized';
    402: Result := 'Payment Required';
    403: Result := 'Forbidden';
    404: Result := 'Not Found';
    405: Result := 'Method Not Allowed';
    406: Result := 'Not Acceptable';
    407: Result := 'Proxy Authentication Required';
    408: Result := 'Request Timeout';
    409: Result := 'Conflict';
    410: Result := 'Gone';
    411: Result := 'Length Required';
    412: Result := 'Precondition Failed';
    413: Result := 'Request Entity Too Large';
    414: Result := 'Request-URI Too Long';
    415: Result := 'Unsupported Media Type';
    416: Result := 'Request Range Not Satisfiable';
    417: Result := 'Expectation Failed';
    422: Result := 'Unprocessable Entity';
    423: Result := 'Locked';
    424: Result := 'Failed Dependency';
    500: Result := 'Internal Server Error';
    501: Result := 'Not Implemented';
    502: Result := 'Bad Gateway';
    503: Result := 'Service Unavailable';
    504: Result := 'Gateway Timeout';
    505: Result := 'Http Version Not Supported';
    506: Result := 'Variant Also Negotiates';
    507: Result := 'Insufficient Storage';
  else
    Result := '';
  end;
end;

class function TSparkleUtils.ISOToTime(const Value: string): TTime;
begin
  if not TryISOToTime(Value, Result) then
    raise EConvertError.CreateFmt(SInvalidDateFormat, [Value]);
end;

class function TSparkleUtils.TimeToISO(const Value: TTime): string;
begin
  Result := TBclUtils.TimeToISO(Value);
end;

class function TSparkleUtils.TryISOToTime(const Value: string; out DateTime: TTime): boolean;
begin
  Result := TBclUtils.TryISOToTIme(Value, DateTime);
end;

class function TSparkleUtils.ISOToDateTime(const Value: string): TDateTime;
begin
  if not TryISOToDateTime(Value, Result) then
    raise EConvertError.CreateFmt(SInvalidDateFormat, [Value]);
end;

class function TSparkleUtils.ParseContentDisposition(
  const Value: string): TContentDispositionInfo;
begin
  Result := ParseHeaderParams(Value);
end;

class function TSparkleUtils.ParseContentType(
  const Value: string): TContentTypeInfo;
begin
  Result := ParseHeaderParams(Value);
end;

class procedure TSparkleUtils.ParseHeader(const Header: string; var Name,
  Value: string);
begin
  ExtractNameValue(Header, ':', Name, Value);
  Name := Trim(Name);
end;

class function TSparkleUtils.ParseHeaderParams(
  const Header: string): THeaderParamsInfo;

  function _Unquote(const S: string): string;
  begin
    if (Length(S) > 2) and (S[1] = '"') and (S[Length(S)] = '"') then
      Result := Copy(S, 2, Length(S) - 2)
    else
      Result := S;
  end;

  function HeaderValue(const S: string): string;
  var
    P: Integer;
  begin
    P := Pos(':', S);
    if P = 0 then

  end;

var
  RawParams: TStringDynArray;
  P: Integer;
  I: Integer;
  RawParam: string;
begin
  { This whole function could be optimized later, *if* needed }
  P := Pos(';', Header);
  if P = 0 then
  begin
    Result.Value := Trim(Header);
    Exit;
  end;

  Result.Value := Trim(Copy(Header, 1, P - 1));
  RawParams := SplitString(Copy(Header, P + 1), ';');
  SetLength(Result.Params, Length(RawParams));
  I := 0;
  for RawParam in RawParams do
  begin
    P := Pos('=', RawParam);
    if P > 1 then
    begin
      Result.Params[I].Name := LowerCase(Trim(Copy(RawParam, 1, P - 1)));
      Result.Params[I].Value := _Unquote(Trim(Copy(RawParam, P + 1)));
      Inc(I);
    end;
  end;
end;

class function TSparkleUtils.PercentDecode(const S: string): string;

  function IsHexa(C: Char): boolean;
  begin
    Result := ((C >= '0') and (C <= '9'))
      or ((C >= 'a') and (C <= 'f'))
      or ((C >= 'A') and (C <= 'F'));
  end;

var
  B: TBytes;
  L: integer;
  I: integer;
begin
  SetLength(B, Length(S));
  L := 1;
  I := 0;
  while L <= Length(S) do
  begin
    if (S[L] = '%') and (L + 2 <= Length(S)) and IsHexa(S[L + 1]) and IsHexa(S[L + 2]) then
    begin
      B[I] := StrToInt('$' + S[L + 1] + S[L + 2]);
      Inc(L, 3);
    end
    else
    begin
      B[I] := Ord(S[L]);
      Inc(L);
    end;
    Inc(I);
  end;
  SetLength(B, I);
  Result := TEncoding.UTF8.GetString(B);
end;

class function TSparkleUtils.PercentEncode(Segments: TArray<string>): string;
var
  Segment: string;
begin
  Result := '';
  for Segment in Segments do
  begin
    if Result <> '' then
      Result := Result + '/';
    Result := Result + PercentEncode(Segment);
  end;
end;

class function TSparkleUtils.PercentEncode(const S: string): string;
begin
  Result := TBclUtils.PercentEncode(S);
end;

class function TSparkleUtils.TryDayTimeDurationToDateTime(const Value: string;
  out Time: TTime): boolean;
var
  Len: integer;
  Day, Hour, Min, Sec: integer;

  function ExtractNumber(const Value: string; var I: integer): boolean;
  var
    Start: integer;
    C: Char;
    Number: integer;
  begin
    Start := I;
    while (I <= Len) and
      {$IFDEF DELPHIXE4_LVL}
      Value[I].IsDigit
      {$ELSE}
      IsDigit(Value[I])
      {$ENDIF}
      do
      Inc(I);
    Result := TryStrToInt(Copy(Value, Start, I - Start), Number) and (I <= Len);
    if Result then
    begin
      C := Value[I];
      Inc(I);
      if C = 'D' then
        Day := Number
      else
      if C = 'H' then
        Hour := Number
      else
      if C = 'M' then
        Min := Number
      else
      if C = 'S' then
        Sec := Number
      else
        Result := false;
    end;
  end;

var
  I: integer;
begin
  Len := Length(Value);
  if (Len = 0) or (Value[1] <> 'P') then
    Exit(false);
  I := 2;

  Day := 0;
  Hour := 0;
  Min := 0;
  Sec := 0;

  // at least one part must exist
  if not ExtractNumber(Value, I) then
    Exit(false);

  // now extract as many as exist
  while ExtractNumber(Value, I) do ;
  Time := EncodeTime(Hour, Min, Sec, 0);
  Result := true;
end;

class function TSparkleUtils.TryISOToDateTime(const Value: string;
  out DateTime: TDateTime): boolean;
begin
  Result := TBclUtils.TryISOToDateTime(Value, DateTime);
end;

class function TSparkleUtils.TryStringToGuid(const Value: string;
  out Guid: TGuid): boolean;
begin
  Result := TBclUtils.TryStringToGuid(Value, Guid);
end;

class function TSparkleUtils.TryISOToDate(const Value: string; out DateTime: TDate): boolean;
begin
  Result := TBclUtils.TryISOToDate(Value, DateTime);
end;

class function TSparkleUtils.ISOToDate(const Value: string): TDate;
begin
  if not TryISOToDate(Value, Result) then
    raise EConvertError.CreateFmt(SInvalidDateFormat, [Value]);
end;

class function TSparkleUtils.DateToISO(const Value: TDate): string;
begin
  Result := TBclUtils.DateToISO(Value);
end;

{ TNameValuePair }

constructor TNameValuePair.Create(const AName, AValue: string);
begin
  Name := AName;
  Value := AValue;
end;

{ THeaderParamsInfo }

function THeaderParamsInfo.ParamValue(const Name: string): string;
begin
  if not TryParamValue(Name, Result) then
    Result := '';
end;

function THeaderParamsInfo.TryParamValue(const Name: string;
  var Value: string): Boolean;
var
  I: Integer;
begin
  for I := 0 to Length(Params) - 1 do
    if SameText(Name, Params[I].Name) then
    begin
      Value := Params[I].Value;
      Exit(True);
    end;
  Result := False;
end;

end.

