FastReport_2022_VCL/Source/frxNetUtils.pas

{******************************************}
{                                          }
{             FastReport VCL               }
{         Network utilities unit           }
{                                          }
{         Copyright (c) 1998-2021          }
{            by Fast Reports Inc.          }
{                                          }
{******************************************}

unit frxNetUtils;

{$I frx.inc}

interface

uses
{$IFNDEF Linux}
  Windows,
{$ELSE}
  LCLType, LCLIntf, LazHelper, dateutils,
{$ENDIF}
  Messages, SysUtils, Classes, Registry;

function DateTimeToRFCDateTime(const D: TDateTime): String;
function GMTDateTimeToRFCDateTime(const D: TDateTime): String;
function PadRight(const S: String; const PadChar: Char; const Len: Integer): String;
function PadLeft(const S: String; const PadChar: Char; const Len: Integer): String;
function Base64Encode(const S: AnsiString): AnsiString;
function Base64Decode(const S: AnsiString): AnsiString;
function Base64URLDecode(const S: AnsiString): AnsiString;
function GetFileMIMEType(const FileName: String): String;
function GetSocketErrorText(const ErrorCode: integer):string;
function UpdateCookies(const Header: String; const Cookies: String): String;
function ParseHeaderField(const Field: AnsiString; const Header: AnsiString): AnsiString;
procedure PMessages;

implementation

const
  Base64Charset = AnsiString('ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/');
  RFCDayNames : Array[1..7] of String = (
      'Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat');
  RFCMonthNames : Array[1..12] of String = (
      'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');

function GMTDateTimeToRFCDateTime(const D: TDateTime): String;
var
  Ho, Mi, Se, Ms : Word;
  Ye, Mo, Da : Word;
begin
  DecodeTime(D, Ho, Mi, Se, Ms);
  DecodeDate(D, Ye, Mo, Da);
  Result := RFCDayNames[DayOfWeek(D)] + ', ';
  Result := Result + PadLeft(IntToStr(Da), '0', 2) + ' ' +
    RFCMonthNames[Mo] + ' ' + IntToStr(Ye) + ' ';
  Result := Result + PadLeft(IntToStr(Ho), '0', 2) + ':' + PadLeft(IntToStr(Mi), '0', 2);
  Result := Result + ':' + PadLeft(IntToStr(Se), '0', 2);
  Result := Result + ' GMT';
end;

{$IFNDEF Linux}
function GMTBias : Integer;
var
  TZI : TTimeZoneInformation;
begin
  if GetTimeZoneInformation(TZI) = TIME_ZONE_ID_DAYLIGHT then
    Result := TZI.DaylightBias
  else
    Result := 0;
  Result := Result + TZI.Bias;
end;
{$ENDIF}

function DateTimeToRFCDateTime(const D: TDateTime): String;
begin
  {$IFNDEF Linux}
  Result := GMTDateTimeToRFCDateTime(D + GMTBias / (24.0 * 60.0));
  {$ELSE}
  Result := GMTDateTimeToRFCDateTime(LocalTimeToUniversal(D));
  {$ENDIF}
end;

function PadLeft(const S: String; const PadChar: Char; const Len: Integer): String;
var
  F, L, P, M : Integer;
  I, J: PChar;
begin
  if Len > 0 then
  begin
    M := Length(S);
    if Len <> M then
    begin
      L := Len;
      P := L - M;
      if P < 0 then
        P := 0;
{$IFDEF DELPHI12}
      Result := StringOfChar(PadChar, L);
{$ELSE}
      SetLength(Result, L);
      if P > 0 then
        FillChar(Pointer(Result)^, P, Ord(PadChar));
{$ENDIF}
      if L > P then
      begin
        I := Pointer(Result);
        J := Pointer(S);
        Inc(I, P);
        for F := 1 to L - P do
        begin
          I^ := J^;
          Inc(I);
          Inc(J);
        end;
      end;
    end else
      Result := S;
  end else
    Result := '';
end;

function PadRight(const S: String; const PadChar: Char; const Len: Integer): String;
var
  F, L, P, M : Integer;
  I, J: PAnsiChar;
begin
  if Len > 0 then
  begin
    M := Length(S);
    if Len <> M then
    begin
      L := Len;
      P := L - M;
      if P < 0 then
        P := 0;
{$IFNDEF DELPHI12}
      SetLength(Result, L);
{$ELSE}
      Result := StringOfChar(PadChar, L);
{$ENDIF}
      if L > P then
      begin
        I := Pointer(Result);
        J := Pointer(S);
        for F := 1 to L - P do
        begin
          I^ := J^;
          Inc(I);
          Inc(J);
        end;
      end;
{$IFNDEF DELPHI12}
      if P > 0 then
        FillChar(Result[L - P + 1], P, Ord(PadChar));
{$ENDIF}
    end else
      Result := S;
  end else
    Result := '';
end;

function Base64Encode(const S: AnsiString): AnsiString;
var
  R, C : Byte;
  F, L, M, N, U : Integer;
  P : PAnsiChar;
begin
  L := Length(S);
  if L > 0 then
  begin
    M := L mod 3;
    N := (L div 3) * 4 + M;
    if M > 0 then Inc(N);
    U := N mod 4;
    if U > 0 then
    begin
      U := 4 - U;
      Inc(N, U);
    end;
    SetLength(Result, N);
    P := Pointer(Result);
    R := 0;
    for F := 0 to L - 1 do
    begin
      C := Byte(S [F + 1]);
      case F mod 3 of
        0 : begin
              P^ := Base64Charset[C shr 2 + 1];
              Inc(P);
              R := (C and 3) shl 4;
            end;
        1 : begin
              P^ := Base64Charset[C shr 4 + R + 1];
              Inc(P);
              R := (C and $0F) shl 2;
            end;
        2 : begin
              P^ := Base64Charset[C shr 6 + R + 1];
              Inc(P);
              P^ := Base64Charset[C and $3F + 1];
              Inc(P);
            end;
      end;
    end;
    if M > 0 then
    begin
      P^ := Base64Charset[R + 1];
      Inc(P);
    end;
    for F := 1 to U do
    begin
      P^ := '=';
      Inc(P);
    end;
  end else
    Result := '';
end;

function Base64Decode(const S: AnsiString): AnsiString;
var
  F, L, M, P: Integer;
  B, OutPos: Byte;
  OutB: Array[1..3] of Byte;
  Lookup: Array[AnsiChar] of Byte;
  R: PAnsiChar;
begin
  L := Length(S);
  P := 0;
  while (L - P > 0) and (S[L - P] = '=') do Inc(P);
  M := L - P;
  if M <> 0 then
  begin
    SetLength(Result, (M * 3) div 4);
    FillChar(Lookup, Sizeof(Lookup), #0);
    for F := 0 to 63 do
      Lookup[Base64Charset[F + 1]] := F;
    R := Pointer(Result);
    OutPos := 0;
    for F := 1 to L - P do
    begin
      B := Lookup[S[F]];
      case OutPos of
          0 : OutB[1] := B shl 2;
          1 : begin
                OutB[1] := OutB[1] or (B shr 4);
                R^ := AnsiChar(OutB[1]);
                Inc(R);
                OutB[2] := (B shl 4) and $FF;
              end;
          2 : begin
                OutB[2] := OutB[2] or (B shr 2);
                R^ := AnsiChar(OutB[2]);
                Inc(R);
                OutB[3] := (B shl 6) and $FF;
              end;
          3 : begin
                OutB[3] := OutB[3] or B;
                R^ := AnsiChar(OutB[3]);
                Inc(R);
              end;
        end;
      OutPos := (OutPos + 1) mod 4;
    end;
    if (OutPos > 0) and (P = 0) then
      if OutB[OutPos] <> 0 then
        Result := Result + AnsiChar(OutB[OutPos]);
  end else
    Result := '';
end;

function Base64URLDecode(const S: AnsiString): AnsiString;
var
  buf: String;
begin
  buf := String(S);
  buf  := StringReplace(buf, '-', '+', [rfReplaceAll, rfIgnoreCase]);
  buf  := StringReplace(buf, '_', '/', [rfReplaceAll, rfIgnoreCase]);
  buf  := StringReplace(buf, '%', '=', [rfReplaceAll, rfIgnoreCase]);
  Result := Base64Decode(AnsiString(buf));
end;

function GetFileMIMEType(const FileName: String): String;
var
  Registry: TRegistry;
  ext: String;
begin
  Result := 'application/octet-stream';
  ext := ExtractFileExt(FileName);
  Registry  := TRegistry.Create;
  try
    Registry.RootKey := HKEY_CLASSES_ROOT;
    if Registry.KeyExists(ext) then
    begin
      Registry.OpenKey(ext, false);
      Result := Registry.ReadString('Content Type');
      Registry.CloseKey;
    end;
  finally
    Registry.Free;
  end;
end;

function GetSocketErrorText(const ErrorCode: integer):string;
begin
  case errorcode of
    10004: result:=   'Interrupted system call.';
    10009: result:=   'Bad file number.';
    10013: result:=   'Access denied.';
    10014: result:=   'Bad address.';
    10022: result:=   'Invalid argument.';
    10024: result:=   'Too many open files.';
    10035: result:=   'Operation would block. Check also the DataToSend property of the component (if any).';
    10036: result:=   'Operation now in progress.';
    10037: result:=   'Operation already in progress.';
    10038: result:=   'Socket operation on non-socket.';
    10039: result:=   'Destination address required.';
    10040: result:=   'Message too long.';
    10041: result:=   'Protocol wrong type for socket.';
    10042: result:=   'Bad protocol option.';
    10043: result:=   'Protocol not supported.';
    10044: result:=   'Socket type not supported.';
    10045: result:=   'Operation not supported on socket.';
    10046: result:=   'Protocol family not supported.';
    10047: result:=   'Address family not supported by protocol family.';
    10048: result:=   'Address already in use.';
    10049: result:=   'Can''t assign requested address.';
    10050: result:=   'Network is down.';
    10051: result:=   'Network is unreachable.';
    10052: result:=   'Net dropped connection or reset.';
    10053: result:=   'Software caused connection abort.';
    10054: result:=   'Connection reset by peer.';
    10055: result:=   'No buffer space available.';
    10056: result:=   'Socket is already connected.';
    10057: result:=   'Socket is not connected.';
    10058: result:=   'Can''t send after socket shutdown.';
    10059: result:=   'Too many references, can''t splice.';
    10060: result:=   'Connection timed out.';
    10061: result:=   'Connection refused.';
    10062: result:=   'Too many levels of symbolic links.';
    10063: result:=   'File name too long.';
    10064: result:=   'Host is down.';
    10065: result:=   'No route to host.';
    10066: result:=   'Directory not empty.';
    10067: result:=   'Too many processes.';
    10068: result:=   'Too many users.';
    10069: result:=   'Disc Quota Exceeded.';
    10070: result:=   'Stale NFS file handle.';
    10071: result:=   'Too many levels of remote in path.';
    10091: result:=   'Network subsystem is unavailable.';
    10092: result:=   'WINSOCK DLL Version out of range.';
    10093: result:=   'Winsock not loaded yet.';
    11001: result:=   'Host not found.';
    11002: result:=   'Non-authoritative ''Host not found'' (try again or check DNS setup).';
    11003: result:=   'Non-recoverable errors: FORMERR, REFUSED, NOTIMP.';
    11004: result:=   'Valid name, no data record (check DNSsetup).';
    500:   result:=   'Exception occured with astadataset';
    501:   result:=   'Unauthorized remote control attempted'
    else
      Result := 'Unknown error'
  end;
  Result := Result + '(' + IntToStr(errorcode) + ')';
end;

procedure PMessages;
var
  Msg: TMsg;
begin
  while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do begin
    if Msg.Message = WM_QUIT then exit;
    {$IFNDEF Linux} //TODO?
    TranslateMessage(Msg);
    DispatchMessage(Msg);
    {$ENDIF}
  end;
  Sleep(1);
end;

function PosOffset(const SubStr, S: string; Offset: Cardinal = 1): Integer;
var
  I,X: Integer;
  Len, LenSubStr: Integer;
begin
  if Offset = 1 then
    Result := Pos(SubStr, S)
  else
  begin
    I := Offset;
    LenSubStr := Length(SubStr);
    Len := Length(S) - LenSubStr + 1;
    while I <= Len do
    begin
      if S[I] = SubStr[1] then
      begin
        X := 1;
        while (X < LenSubStr) and (S[I + X] = SubStr[X + 1]) do
          Inc(X);
        if (X = LenSubStr) then
        begin
          Result := I;
          exit;
        end;
      end;
      Inc(I);
    end;
    Result := 0;
  end;
end;

function UpdateCookies(const Header: String; const Cookies: String): String;
var
  s, c: String;
  i, j: Integer;
begin
  result := Cookies;
  i := 1;
  s := 'Set-Cookie: ';
  while i > 0 do
  begin
    i := PosOffset(s, Header, i);
    if i > 0 then
    begin
      i := i + Length(s);
      j := PosOffset(';', Header, i);
      if j > 0 then
      begin
        c := Copy(Header, i, j - i);
        if Pos(c, result) = 0 then
        begin
          if result <> '' then
            Result := Result + '; ';
          result := result + c;
        end;
        i := j;
      end;
    end;
  end;
end;

function ParseHeaderField(const Field: AnsiString; const Header: AnsiString): AnsiString;
var
  i: integer;
  s: Ansistring;
begin
  i := Pos(Field, Header);
  Result := '';
  if i > 0 then
  begin
    s := Copy(Header, i + Length(Field), Length(Header) - i + Length(Field));
    i := Pos(AnsiString(#13#10), s);
    if i > 0 then
      Result := Copy(s, 1, i - 1);
  end;
end;

end.