RnQ/RnQ/RnQ_Avatars.pas

{
  This file is part of R&Q.
  Under same license
}
unit RnQ_Avatars;
{$I RnQConfig.inc}

interface

uses
  Winapi.Windows, System.SysUtils, System.Classes, System.Net.HttpClient,
  RnQGraphics32, RDGlobal, ICQCommon, ICQContacts, ICQSession;

{$I NoRTTI.inc}
// const
// AvatarFile = '%s\%d.jpeg';

// type
// TPAFormat = (PA_FORMAT_UNK, PA_FORMAT_BMP, PA_FORMAT_JPEG,
// PA_FORMAT_GIF, PA_FORMAT_PNG, PA_FORMAT_XML);

function FormatAvatarFileName(const APath: String; const AUIN: AnsiString; AFormat: TPAFormat): String;
// function DetectAvatarFormatBuffer(pBuffer: String): TPAFormat;
function GetDomain(url: String): String;
procedure FindAndSaveVibrantColors(PicType: Integer; var str: TMemoryStream; var cnt: TICQContact);
procedure SaveAndLoadAvatar(cnt: TICQContact; var str: TMemoryStream);
procedure ShowAvatarError(var Cnt: TICQContact);
procedure LoadAvatars(const proto: TICQSession; path: String);
procedure UpdateAnPFor(c: TICQContact);
function CheckAvatar(const cont: TICQContact): Boolean;
procedure ClearAoP(var contact: TICQContact; PicType: Integer);
function TryLoadAvatar(c: TICQContact): Boolean;
procedure DownloadAvatar(c: TICQContact);
procedure RemoveAllContactAorP(Cnt: TICQContact; PicType: Integer);
function LoadAvtByUIN(const uin: TUID; var bmp: TRnQBitmap; var hasAvatar: Boolean; var pPicFile: String): Boolean;
function LoadAoPStreamByUIN(const uin: TUID; var mem: TMemoryStream; var hasAoP: Boolean; var pPicFile: String; PicType: Integer): Boolean;
procedure UpdateAnP(c: TICQContact { ; pWriteLog : boolean = false } );

// JPEG_HDR  = AnsiString(#$FF#$D8#$FF#$E0);
// JPEG_HDR2 = AnsiString(#$FF#$D8#$FF#$E1);

const
  ICQ_AVATAR_URL = 'https://api.icq.net/expressions/get?f=native&type=floorOriginalBuddyIcon&t='; // floorLargeBuddyIcon
  ICQ_PHOTO_AVATAR = 'https://www.icq.com/img/show_photo.php?th_type=1&uin=%s&gender=%d';
  //ICQ_PHOTO_URL = 'https://www.icq.com/img/show_photo.php?uin=';
  ICQ_THUMB_URL = 'https://www.icq.com/img/show_thumb.php?uin=';

type
  // TOnDownloadedProc = Procedure(fn : String; size : Int64; proto : TICQSession; uid : TUID);
  TOnDownloadedProc = Procedure(fn: String; size: Int64; cnt: TICQContact);

  TLoadURLParams = record
    url: String;
    fn: String;
    Treshold: LongInt;
    ExtByContent: Boolean;
    // UID : TUID;
    // fProto : TICQSession;
    cnt: TICQContact;
    Proc: TOnDownloadedProc;
  end;

implementation

uses
  System.StrUtils, System.Math,
{$IFDEF UNICODE}
  System.AnsiStrings,
{$ENDIF UNICODE}
  SciterLib, UtilLib, GlobalLib, RoasterLib,
  RQUtil, RnQLangs, RnQNet, RDUtils, RnQGlobal, ICQConsts;

procedure SaveAvatar(const uin: TUID; picFmt: TPAFormat; const str: TMemoryStream);
var
  s: String;
begin
  if str.size = 0 then
    Exit;

  if not (uin = '') then
  begin
    s := AccPath + avtPath + uin + '.avatar' + PAFormat[picFmt];
    str.SaveToFile(s);
  end;
end;

function FormatAvatarFileName(const APath: String; const AUIN: AnsiString; AFormat: TPAFormat): String;
begin
  Result := Format('%s%s%s', [APath, AUIN, PAFormat[AFormat]]);
end;

{ function DetectAvatarFormatBuffer(pBuffer: String): TPAFormat;
  var
  s : String;
  begin
  s := Copy(pBuffer, 1, 4);
  if s = 'GIF8' then
  Result:= PA_FORMAT_GIF
  else if (s = JPEG_HDR) or (s = JPEG_HDR2) then
  Result:= PA_FORMAT_JPEG
  else if StartsText('BM', s) then
  Result:= PA_FORMAT_BMP
  else if s = '
  Result:= PA_FORMAT_XML
  else if StartsText('<27>PNG', s) then
  Result:= PA_FORMAT_PNG
  else
  Result:= PA_FORMAT_UNK;
  end;
}
function GetDomain(url: String): String;
var
  i, k, l: Integer;
begin
  i := 1;
  if AnsiStartsText('http://', url) then
    Delete(url, 1, 7);
  i := PosEx('/', url, i);
  Delete(url, i, 10000);
  k := 1;
  repeat
    l := k + 1;
    k := PosEx('.', url, l);
    if k > 0 then
      i := l;
  until k <= 0;
  Result := copy(url, i, 10000);
end;

procedure FindAndSaveVibrantColors(PicType: Integer; var str: TMemoryStream; var cnt: TICQContact);
var
  colors: TParams;
begin
  if not Assigned(UI.Chat) or (str.Size = 0) then
    Exit;

  try
    colors := UI.GetImageColors(str);
    if Assigned(colors) and (Length(colors) >= 2) then
    begin
      if PicType = 0 then
      begin
        cnt.IconColors.AvatarBack := colors[0];
        cnt.IconColors.AvatarText := colors[1];
      end
        else
      begin
        cnt.IconColors.PhotoBack := colors[0];
        cnt.IconColors.PhotoText := colors[1];
      end;
    end
      else
    begin
      if PicType = 0 then
      begin
        cnt.IconColors.AvatarBack := '';
        cnt.IconColors.AvatarText := '';
      end
        else
      begin
        cnt.IconColors.PhotoBack := '';
        cnt.IconColors.PhotoText := '';
      end;
    end;
  except end;
end;

procedure SaveAndLoadAvatar(cnt: TICQContact; var str: TMemoryStream);
var
  picFmt: TPAFormat;
begin
  picFmt := DetectFileFormatStream(str);
  if not (picFmt = PA_FORMAT_UNK) then
    SaveAvatar(cnt.UID, picFmt, str);

  if cnt is TICQContact then
  begin
    if picFmt <> PA_FORMAT_UNK then
    begin
      FindAndSaveVibrantColors(0, str, cnt);
      if cnt.icon.ToShow = IS_AVATAR then
      begin
        str.Position := 0;
        if LoadPic(TStream(str), cnt.icon.bmp, 0, picFmt) then
          StretchPic(cnt.icon.bmp, maxPICAVTH, maxPICAVTW);

        cnt.icon.IsBmp := True;
        if cnt.icon.bmp.Animated then
          cnt.icon_Path := '';
      end;
    end else if cnt.icon.ToShow = IS_AVATAR then
    begin
      if Assigned(cnt.icon.bmp) then
        cnt.icon.bmp.Free;
      cnt.icon.bmp := nil;
      msgDlg(getTranslation('[%s] has avatar of unsupported type', [cnt.displayed]), False, mtError);
    end;
  end;
end;

function LoadAvtByUIN(const uin: TUID; var bmp: TRnQBitmap; var hasAvatar: Boolean; var pPicFile: String): Boolean;
var
  sr: TsearchRec;
  path: String;
begin
  Result := False;
  path := AccPath + avtPath;
  if (path = '') or not directoryExists(path) then
    Exit;
  path := includeTrailingPathDelimiter(path);
  ZeroMemory(@sr.FindData, SizeOf(TWin32FindData));
  if FindFirst(path + uin + '.avatar.*', faAnyFile, sr) = 0 then
    repeat
      // if (sr.name<>'.') and (sr.name<>'..') then
      if (sr.name = '.') or (sr.name = '..') then
        Continue;
      pPicFile := path + sr.name;
      // if sr.Attr and faDirectory > 0 then
      if isSupportedPicFile(sr.name) then
      begin
        hasAvatar := True;
        begin
          Result := loadPic2(pPicFile, bmp);
          if Result then
          begin
            StretchPic(bmp, maxPICAVTH, maxPICAVTW);
            Break;
          end
          else
          begin
            DeleteFile(pPicFile);
            pPicFile := '';
          end;;
        end;
      end;
    until findNext(sr) <> 0;
  findClose(sr);
end;

function LoadAoPStreamByUIN(const uin: TUID; var mem: TMemoryStream; var hasAoP: Boolean; var pPicFile: String; PicType: Integer): Boolean;
var
  sr: TsearchRec;
  path: String;
  fs: TFileStream;
begin
  Result := False;
  path := AccPath + avtPath;
  if (path = '') or not DirectoryExists(path) then
    Exit;
  path := IncludeTrailingPathDelimiter(path);
  ZeroMemory(@sr.FindData, SizeOf(TWin32FindData));
  if FindFirst(path + uin + IfThen(PicType = 0, '.avatar.*', '.photo.*'), faAnyFile, sr) = 0 then
  repeat
    if (sr.name = '.') or (sr.name = '..') or not IsSupportedPicFile(sr.name) then
      Continue;
    pPicFile := path + sr.name;
    hasAoP := True;
    fs := TFileStream.Create(pPicFile, fmOpenRead);
    try
      mem.Clear;
      mem.LoadFromStream(fs);
      mem.Seek(0, soFromBeginning);
      Result := True;
    except end;
    fs.Free;
    Break
  until FindNext(sr) <> 0;
  FindClose(sr);
end;

function TryLoadAvatar(c: TICQContact): Boolean;
var
  path : String;
//  sr:TsearchRec;
  hasAvatar, b : Boolean;
begin
  Result := False;
  if not Account.AccProto.AvatarsSupport then
    Exit;
  hasAvatar := c.icon.ToShow <> IS_AVATAR;

  if not hasAvatar then
  begin
    b := LoadAvtByUIN(c.UID, c.icon.Bmp, hasAvatar, path);
    if b then
    begin
      if Assigned(c.icon.Bmp) then
        c.icon.IsBmp := c.icon.Bmp.fFormat <> PA_FORMAT_SWF
       else
        c.icon.IsBmp := False;
      if not c.icon.IsBmp then
        c.icon_Path := path
       else
        c.Icon_Path := '';
    end
  end;

  UpdateAnPFor(c);
  Result := hasAvatar;
end;

procedure ShowAvatarError(var Cnt: TICQContact);
begin
  if AvatarsNotDnlddInform then
    MsgDlg(GetTranslation('Contact [%s] doesn''t have an avatar or its download failed',
    [IfThen(Cnt.displayed = '', Cnt.UID, Cnt.displayed)]), False, mtInformation);
end;

procedure DownloadAvtFromURL(Cnt: TICQContact);
begin
  LoadFromURLAsync(ICQ_AVATAR_URL + Cnt.uid, procedure(Sender: TObject; const Response: IHTTPResponse; const Error: String = '')
  var
    Mem: TMemoryStream;
    Client: THttpAsync;
  begin
    Client := Sender as THttpAsync;
    if not Assigned(Client) or not Assigned(Response) then
      Exit;

    Mem := nil;
    try
      if HandleStatus(Response.StatusCode) and Assigned(Response.ContentStream) and (Response.ContentLength > 0) then
      begin
        Response.ContentStream.Seek(0, soFromBeginning);
        Mem := TMemoryStream.Create;
        Mem.CopyFrom(Response.ContentStream);
        SaveAndLoadAvatar(Cnt, Mem);
      end else
        ShowAvatarError(Cnt);
      TryLoadAvatar(Cnt);
    finally
      FreeAndNil(Mem);
      FreeAndNil(Client);
    end;
  end);
end;

procedure DownloadAvatar(c: TICQContact);
begin
  if not Account.AccProto.AvatarsSupport or not Assigned(c) then
    Exit;
  RemoveAllContactAorP(c, 0);
  DownloadAvtFromURL(c);
end;

procedure RemoveAllContactAorP(Cnt: TICQContact; PicType: Integer);
var
  sr: TSearchRec;
begin
  if FindFirst(AccPath + avtPath + Cnt.UID + IfThen(PicType = 0, '.avatar.*', '.photo.*'), faAnyFile, sr) = 0 then
  repeat
    if (sr.name <> '.') and (sr.name <> '..') then
      if IsSupportedPicFile(sr.name) then
        DeleteFile(AccPath + avtPath + sr.name);
  until FindNext(sr) <> 0;
  FindClose(sr);
end;

procedure UpdateAnP(c: TICQContact { ; pWriteLog : boolean = false } );
var
  sr: TsearchRec;
  // path,
  // uinStr : String;
  // uin, code : Integer;
  // c : Tcontact;
  PicFile: String;
  // b,
  hasAvatar, loaded: Boolean;
begin
  FreeAndNil(c.icon.bmp);
  if (c is TICQContact) and (c.icon.ToShow = IS_AVATAR)  then
  begin
    if FindFirst(IncludeTrailingPathDelimiter(AccPath + avtPath) + c.UID + '.avatar.*', faAnyFile, sr) = 0 then
    begin
      hasAvatar := False;
      { if pWriteLog then
        loggaEvt('Avatars: loading for '+ c.UID + ', hash = '+
        str2hex(TICQcontact(c).ICQIcon.hash_safe), '', True); }
      loaded := LoadAvtByUIN(TICQContact(c).UID, c.icon.bmp, hasAvatar, PicFile);
      if hasAvatar and not loaded then
        msgDlg(getTranslation('Couldn''t load avatar for %s', [c.UID]), False, mtError);
      // hasAvatar := loaded;
      if loaded then
      begin
        if Assigned(c.icon.bmp) and (c.icon.bmp.Animated or (c.icon.bmp.fFormat = PA_FORMAT_SWF)) then
          c.icon_Path := PicFile
        else
          c.icon_Path := '';
        if Assigned(c.icon.bmp) and (c.icon.bmp.fFormat = PA_FORMAT_SWF) then
          c.icon.IsBmp := False
        else
          c.icon.IsBmp := True;
      end;
    end;
    findClose(sr);
  end
  else if c.icon.ToShow = IS_PHOTO then
  begin
    if FindFirst(AccPath + avtPath + c.UID + '.photo.*', faAnyFile, sr) = 0 then
    begin
      PicFile := AccPath + avtPath + sr.name;
      if isSupportedPicFile(PicFile) then
      begin
        { if pWriteLog then
          loggaEvt('Avatars: loading photo for '+ c.UID + ', file = '+ PicFile, '', True); }
        if loadPic2(PicFile, c.icon.bmp) then
          // if Assigned(c.iconBmp) then
          StretchPic(c.icon.bmp, maxPICAVTH, maxPICAVTW);
        c.icon.IsBmp := True;
        if Assigned(c.icon.bmp) and c.icon.bmp.Animated then
          c.icon_Path := PicFile
        else
          c.icon_Path := '';
      end;
    end;
    findClose(sr);
  end;
end;

procedure loadAvatars(const proto: TICQSession; path: String);
//var
  // sr:TsearchRec;
  // path,
  // uinStr : String;
  // uin, code : Integer;
  // c : TICQcontact;
  // b, hasAvatar, loaded : Boolean;
begin
  // path := userPath + avtPath;
  if not Account.AccProto.AvatarsSupport then
    Exit;
  if (path = '') or not directoryExists(path) then
    Exit;

  path := includeTrailingPathDelimiter(path);
  proto.readList(LT_ROSTER).ForEach(procedure(cnt: TICQContact)
  begin
    updateAnP(cnt);
  end);
end;

procedure UpdateAnPFor(c: TICQContact);
begin
  if not Assigned(c) then
    Exit;

  UI.UpdateViewInfoAnP(c.UID);

  if avatarShowInChat then
    UI.Chat.UpdateAvatar(c);

  if TO_SHOW_ICON[CNT_ICON_AVT] then
    roasterLib.UpdateInPlace(c);
end;

procedure ClearAoP(var Contact: TICQContact; PicType: Integer);
var
  sr: TSearchRec;
  path: String;
begin
  if not Assigned(Contact) then
    Exit;

  path := IncludeTrailingPathDelimiter(AccPath + avtPath);
  if not (path = '') and DirectoryExists(path) then
  begin
    ZeroMemory(@sr.FindData, SizeOf(TWin32FindData));
    if FindFirst(path + Contact.UID + IfThen(PicType = 0, '.avatar.*', '.photo.*'), faAnyFile, sr) = 0 then
    repeat
      if (sr.name = '.') or (sr.name = '..') then
        Continue;
      DeleteFile(path + sr.name);
    until FindNext(sr) <> 0;
    FindClose(sr);
  end;

  if PicType = 0 then
  begin
    Contact.IconColors.AvatarBack := '';
    Contact.IconColors.AvatarText := '';
    if Account.AccProto.IsMyAcc(Contact) then
      Account.AccProto.MyAvatarHash := '';
  end
    else
  begin
    Contact.IconColors.PhotoBack := '';
    Contact.IconColors.PhotoText := '';
  end;

  with Contact do
  begin
    IconID := '';
    FreeAndNil(icon.bmp);
    icon_Path := '';
    UpdateAnPFor(Contact);
  end;
end;

function CheckAvatar(const cont: TICQContact): Boolean;
var
  Path: String;
  SR: TsearchRec;
begin
  Result := False;

  if not Account.AccProto.AvatarsSupport or not Assigned(cont) then
    Exit;

  Path := AccPath + avtPath;
  if (Path = '') or not DirectoryExists(path) then
    Exit;

  Path := IncludeTrailingPathDelimiter(Path);
  Result := False;
  if FindFirst(Path + cont.UID + '.avatar.*', faAnyFile, SR) = 0 then
  repeat
    if not (SR.name = '.') and not (SR.name = '..') then
    if not (LowerCase(ExtractFileExt(path + SR.name)) = '.swf') then
    begin
      Result := True;
      Break;
    end;
  until FindNext(SR) <> 0;
  FindClose(SR);
end;

end.