{***************************************************************************}
{ TMS Cloud base infrastructure                                             }
{ for Delphi & C++Builder                                                   }
{                                                                           }
{ written by TMS Software                                                   }
{            copyright © 2012                                               }
{            Email : info@tmssoftware.com                                   }
{            Web : http://www.tmssoftware.com                               }
{                                                                           }
{ The source code is given as is. The author is not responsible             }
{ for any possible damage done due to the use of this code.                 }
{ The component can be freely used in any application. The complete         }
{ source code remains property of the author and may not be distributed,    }
{ published, given or sold in any form as such. No parts of the source      }
{ code can be included in any other component or application without        }
{ written authorization of the author.                                      }
{***************************************************************************}

unit CloudBase;

{$I TMSDEFS.INC}

{$R CloudBase.RES}

interface

uses
  Classes, DBXJSON, IdGlobal, Forms, ShDocVW, Controls, ComCtrls;

const
  MAJ_VER = 1; // Major version nr.
  MIN_VER = 0; // Minor version nr.
  REL_VER = 0; // Release nr.
  BLD_VER = 1; // Build nr.

  // v1.0.0.0 : First release
  // v1.0.0.1 : Fixed : Memory leak issue in download to file

type
  TCoreCloudHeader = record
    header: String;
    value: String;
  end;

  TCoreCloudHeaders = array of TCoreCloudHeader;

  THTTPCommand = (hcPost,hcPut,hcPostMultiPart,hcPutMultiPart,hcPutNoHeader);

  TProgressEvent = procedure(Sender: TObject; FileName: string; Position, Total: int64) of object;

  TAuthFormSettings = class(TPersistent)
  private
    FWidth: integer;
    FCaption: string;
    FHeight: integer;
  public
    constructor Create;
    procedure Assign(Source: TPersistent); override;
  published
    property Caption: string read FCaption write FCaption;
    property Width: integer read FWidth write FWidth;
    property Height: integer read FHeight write FHeight;
  end;

  TPersistLocation = (plIniFile, plRegistry);

  TPersistTokens = class(TPersistent)
  private
    FLocation: TPersistLocation;
    FSection: string;
    FKey: string;
  public
    procedure Assign(Source: TPersistent); override;
  published
    property Location: TPersistLocation read FLocation write FLocation;
    property Section: string read FSection write FSection;
    property Key: string read FKey write FKey;
  end;

  TCloudApp = class(TPersistent)
  private
    FSecret: string;
    FKey: string;
    FName: string;
  public
    procedure Assign(Source: TPersistent); override;
  published
    property Name: string read FName write FName;
    property Key: string read FKey write FKey;
    property Secret: string read FSecret write FSecret;
  end;

  TCloudLocale = (lcDefault, lcEnglish, lcDutch, lcGerman, lcFrench, lcSpanish, lcItalian,
     lcPortuguese, lcGreek, lcDanish, lcRussian, lcRomanian, lcSwedish, lcFinnish, lcTurkish,
     lcJapanese);

  {$IFDEF DELPHIXE2_LVL}
  [ComponentPlatformsAttribute(pidWin32 or pidWin64)]
  {$ENDIF}
  TCloudBase = class(TComponent)
  private
    FApp: TCloudApp;
    FPersistTokens: TPersistTokens;
    FToken_Access: string;
    FToken_Auth: string;
    FToken_Auth_Secret: string;
    FToken_Access_Secret: string;
    FToken_Refresh: string;
    FLogFileName: string;
    FAgent: string;
    FOAuthForm: TForm;
    FAuthFormSettings: TAuthFormSettings;
    FRequestParams: TStringList;
    FScopes: TStrings;
    FOnReceivedAccessToken: TNotifyEvent;
    FAuthBrowser: TWebBrowser;
    FOnDownloadProgress: TProgressEvent;
    FOnUploadProgress: TProgressEvent;
    FOnAuthFormClose: TNotifyEvent;
    FLastError: integer;
    FLogging: boolean;
    FLocale: TCloudLocale;
    procedure SetAuthFormSettings(const Value: TAuthFormSettings);
    procedure SetScopes(const Value: TStrings);
    function GetVersion: string;
    procedure SetPersistTokens(const Value: TPersistTokens);
    procedure SetApp(const Value: TCloudApp);
    function GetTokensAsString: string;
    procedure SetTokensAsString(const Value: string);
  protected
    property Token_Access: string read FToken_Access write FToken_Access;
    property Token_Auth: string read FToken_Auth write FToken_Auth;
    property Token_Access_Secret: string read FToken_Access_Secret write FToken_Access_Secret;
    property Token_Auth_Secret: string read FToken_Auth_Secret write FToken_Auth_Secret;
    property Token_Refresh: string read FToken_Refresh write FToken_Refresh;
    function CleanUpJSON(Value: ansistring): ansistring;
    function EncodeParams(Params: TStringList; splitter: String; quot: Boolean; encodeHttp: Boolean = false): string;
    function Base64Encode(const Input: TIdBytes): string;
    function EncryptHMACSha1(Input, AKey: string): TIdBytes;
    function OAuthEncryptHMACSha1(const value,key: string): string;
    procedure DoFormClose(Sender: TObject; var Action: TCloseAction);
    procedure DoReceivedAccessToken; virtual;
    procedure DoDownloadProgress(Filename: string; position, total: int64); virtual;
    procedure DoUploadProgress(Filename: string; position, total: int64); virtual;
    function CreateOAuthForm(url: string; CallBack: TWebBrowserBeforeNavigate2; CallBackComplete: TWebBrowserNavigateComplete2): TForm;
    procedure CloseOAuthForm;
    procedure Log(Msg: string);
    function GetVersionNr: integer; virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    property Scopes: TStrings read FScopes write SetScopes;
    property RequestParams: TStringList read FRequestParams;
    property LastError: integer read FLastError;
    property LogFileName: string read FLogFileName write FLogFileName;

    procedure LoadTokens;
    procedure SaveTokens;
    procedure ClearTokens;
    function TestTokens: boolean; virtual;
    function RefreshAccess: boolean; virtual;
    property TokensAsString: string read GetTokensAsString write SetTokensAsString;
    procedure DoAuth; virtual;
    procedure RemoveOAuthRequestParams;
    procedure AddOAuthRequestParams(AppKey,AccessToken: string); overload;
    procedure AddOAuthRequestParams(AppKey,AccessToken: string; var TS,Nonce: string); overload;
    function GetOAuthHeader(AppKey, AccessToken, TS, Nonce, Sig: string): string;
    function GetOAuthSigBase(URL,Key,Method: string): string;
    function RequestParamText: string;
    function ScopeParamText(Delimiter: string; Encode: boolean = false): string;
    function SignURL(url: string): string;
    function SpaceEncode(const Url: string): string;
    function URLEncode(const Url: string): string;
    function URLEncodeTilde(const Url: string): string;
    function HTTPEncode(const AStr: ansistring): ansistring;
    function URLEncodeRFC3986(URL: string): string;
    function ExtractServer(url: string): string;
    function RemoveServer(url: string): string;
    function GenerateTimeStamp: string;
    class function LongDateStrToDateTime(const s: string): TDateTime;
    class function IsoToDateTime(const s: string): TDateTime;
    class function IsoToDate(const s: string):TDateTime;
    function DateTimeToIso(dt: TDateTime): string;
    function DateTimeToWL(dt: TDateTime): string;
    function DateToWL(d: TDate): string;
    function GenerateNonce: string;
    function GenerateSignatureBase(url, consumerKey, httpMethod, timeStamp, nonce, signatureType, params: string): string;
    function GetSignature(url: string; appsecret, tokensecret: string): string;
    function ParseTokens(const jsonresult: ansistring; var Token, Secret: string): boolean;
    function GetMimeType(FileName: string): string;

    // base REST HTTP methods
    function HttpError(ErrorCode:Cardinal): string;
    function HttpsDelete(const ServerName,Resource: String; Headers: TCoreCloudHeaders;const  PostData : AnsiString;Var Response:AnsiString): Integer;
    function HttpsPost(const ServerName,Resource: String; Headers: TCoreCloudHeaders;const  PostData : AnsiString;Var Response:AnsiString): Integer;
    function HttpsUpdate(const ServerName,Resource: String; Headers: TCoreCloudHeaders;const  PostData : AnsiString;Var Response:AnsiString): Integer;
    function HttpsPut(url,tgtdir,tgtfn: String; customheaders: TCoreCloudHeaders; customdata: ansistring; HttpCommand: THTTPCommand): ansistring;
    function HttpsGet(const Url: string): ansistring; overload;
    function HttpsGet(const Url: String; Headers: TCoreCloudHeaders): ansistring; overload;
    function HttpsGet(const Url: string; FileName: string; Size: int64): ansistring; overload;
    function HttpsGet(const Url: string; Stream: TMemoryStream; Size: int64): ansistring; overload;
    // base JSON Handling code
    function GetJSONValue(URL, ID: string): string; overload;
    function GetJSONObject(URL: string): TJSONObject;
    class function GetJSONValue(O: TJSONOBject; ID:string): TJSONValue; overload;
    class function GetJSONProp(O: TJSONOBject; ID: string): string; overload;
    class function GetJSONProp(JSON: string; ID: string): string; overload;
    class function StrToIntT(s: string): integer;
    class function StrToInt64T(s: string): uint64;
    property Locale: TCloudLocale read FLocale write FLocale default lcDefault;
  published
    property Agent: string read FAgent write FAgent;
    property App: TCloudApp read FApp write SetApp;
    property AuthBrowser: TWebBrowser read FAuthBrowser write FAuthBrowser;
    property AuthFormSettings: TAuthFormSettings read FAuthFormSettings write SetAuthFormSettings;
    property PersistTokens: TPersistTokens read FPersistTokens write SetPersistTokens;
    property Logging: boolean read FLogging write FLogging;
    property Version: string read GetVersion;
    property OnUploadProgress: TProgressEvent read FOnUploadProgress write FOnUploadProgress;
    property OnDownloadProgress: TProgressEvent read FOnDownloadProgress write FOnDownloadProgress;
    property OnReceivedAccessToken: TNotifyEvent read FOnReceivedAccessToken write FOnReceivedAccessToken;
    property OnAuthFormClose: TNotifyEvent read FOnAuthFormClose write FOnAuthFormClose;
  end;

  TCloudLookupProvider = class(TCloudBase)
  public
    procedure Lookup(AText: string; Values: TStrings); virtual;
  end;


  TCloudItemType = (ciFile, ciFolder);

  TCloudItems = class;

  TCloudItem = class(TCollectionItem)
  private
    FFolder: TCloudItems;
    FFileName: string;
    FItemType: TCloudItemType;
    FSize: int64;
    FModifiedDate: TDateTime;
    FCreationDate: TDateTime;
    FTag: integer;
  protected
    procedure CheckFolder;
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    property FileName: string read FFileName write FFileName;
    property Folder: TCloudItems read FFolder write FFolder;
    property Size: int64 read FSize write FSize;
    property ItemType: TCloudItemType read FItemType write FItemType;
    property CreationDate: TDateTime read FCreationDate write FCreationDate;
    property ModifiedDate: TDateTime read FModifiedDate write FModifiedDate;
    property Tag: integer read FTag write FTag;
  end;

  TCloudItems = class(TCollection)
  private
    FTag: integer;
    function GetItems(index: integer): TCloudItem;
    procedure SetItems(index: integer; const Value: TCloudItem);
  protected
    function GetItemClass: TCollectionItemClass; virtual;
  published
  public
    constructor Create;
    function Add: TCloudItem;
    function Insert(Index: integer): TCloudItem;
    property Items[index: integer]: TCloudItem read GetItems write SetItems;
    property Tag: integer read FTag write FTag;
  end;

  TCloudStorage = class(TCloudBase)
  private
    FDrive: TCloudItems;
    FAPIBase: string;
  protected
    function CreateCloudItems: TCloudItems; virtual;
    property APIBase: string read FAPIBase write FAPIBase;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Drive: TCloudItems read FDrive;
    procedure GetDriveInfo; virtual;
    procedure FillTreeView(ATreeView: TTreeView); virtual;
    function CreateFolder(ci: TCloudItem; const FolderName: string): TCloudItem; virtual;
    function Delete(ci: TCloudItem): boolean; overload; virtual;
    function Delete(const FileName: string): boolean; overload; virtual;
    function Download(ci: TCloudItem; const TargetFile: string): boolean; overload; virtual;
    function Download(const FileName: string; const TargetFile: string): boolean; overload; virtual;
  end;

  function VarPos(sub,s: string; var vp: integer): integer;
  procedure Split(const Delimiter: Char; Input: string; const Strings: TStrings);
  procedure AddHeader(var AHeaders: TCoreCloudHeaders; Header: String; Value: String);

implementation

uses
  WinInet, SysUtils, StrUtils, DateUtils, Windows, Variants,
  IdHash, IdHashMessageDigest, IdHMACSHA1, IdCoderMIME,
  Registry, ShellAPI, ShlObj, ActiveX, INIFiles;

const
  READBUFFERSIZE = 4096;
  C1 = 52845;
  C2 = 22719;

  TIME_ZONE_ID_UNKNOWN  = 0;
  TIME_ZONE_ID_STANDARD = 1;
  TIME_ZONE_ID_DAYLIGHT = 2;

var
  EncodeTable: array[0..63] of Char =
    'ABCDEFGHIJKLMNOPQRSTUVWXYZ' +
    'abcdefghijklmnopqrstuvwxyz' +
    '0123456789+/';

  DecodeTable: array[#0..#127] of Integer = (
    Byte('='), 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64,
    64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64,
    64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 64, 62, 64, 64, 64, 63,
    52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 64, 64, 64, 64, 64, 64,
    64,  0,  1,  2,  3,  4,  5,  6,  7,  8,  9, 10, 11, 12, 13, 14,
    15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 64, 64, 64, 64, 64,
    64, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40,
    41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 64, 64, 64, 64, 64);

const
  UnixStartDate: TDateTime = 25569;

type
  PPacket = ^TPacket;
  TPacket = packed record
    case Integer of
      0: (b0, b1, b2, b3: Byte);
      1: (i: Integer);
      2: (a: array[0..3] of Byte);
      3: (c: array[0..3] of Char);
  end;


function UppercaseA(s: ansistring): ansistring;
begin
  Result := ansistring(Uppercase(string(s)));
end;

procedure AddHeader(var AHeaders: TCoreCloudHeaders; Header: String; Value: String);
begin
  SetLength(AHeaders, Length(AHeaders) + 1);
  AHeaders[Length(AHeaders) - 1].header := Header;
  AHeaders[Length(AHeaders) - 1].value := Value;
end;

function Decode(const S: AnsiString): AnsiString;
const
  Map: array[AnsiChar] of Byte = (0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 62, 0, 0, 0, 63, 52, 53,
    54, 55, 56, 57, 58, 59, 60, 61, 0, 0, 0, 0, 0, 0, 0, 0, 1, 2,
    3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19,
    20, 21, 22, 23, 24, 25, 0, 0, 0, 0, 0, 0, 26, 27, 28, 29, 30,
    31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45,
    46, 47, 48, 49, 50, 51, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
    0);
var
  I: LongInt;
begin
  case Length(S) of
    2:
      begin
        I := Map[S[1]] + (Map[S[2]] shl 6);
        SetLength(Result, 1);
        Move(I, Result[1], Length(Result))
      end;
    3:
      begin
        I := Map[S[1]] + (Map[S[2]] shl 6) + (Map[S[3]] shl 12);
        SetLength(Result, 2);
        Move(I, Result[1], Length(Result))
      end;
    4:
      begin
        I := Map[S[1]] + (Map[S[2]] shl 6) + (Map[S[3]] shl 12) +
          (Map[S[4]] shl 18);
        SetLength(Result, 3);
        Move(I, Result[1], Length(Result))
      end
  end
end;

function PreProcess(const S: AnsiString): AnsiString;
var
  SS: AnsiString;
begin
  SS := S;
  Result := '';
  while SS <> '' do
  begin
    Result := Result + Decode(Copy(SS, 1, 4));
    Delete(SS, 1, 4)
  end
end;

function InternalDecrypt(const S: AnsiString; Key: Word): AnsiString;
var
  I: Word;
  Seed: Word;
begin
  Result := S;
  Seed := Key;
  for I := 1 to Length(Result) do
  begin
    Result[I] := AnsiChar(Byte(Result[I]) xor (Seed shr 8));
    Seed := (Byte(S[I]) + Seed) * Word(C1) + Word(C2)
  end
end;

function Decrypt(const S: AnsiString; Key: Word): AnsiString;
begin
  Result := InternalDecrypt(PreProcess(S), Key)
end;

function Encode(const S: AnsiString): AnsiString;
const
  Map: array[0..63] of AnsiChar = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' +
    'abcdefghijklmnopqrstuvwxyz0123456789+/';
var
  I: LongInt;
begin
  I := 0;
  Move(S[1], I, Length(S));
  case Length(S) of
    1:
      Result := Map[I mod 64] + Map[(I shr 6) mod 64];
    2:
      Result := Map[I mod 64] + Map[(I shr 6) mod 64] +
        Map[(I shr 12) mod 64];
    3:
      Result := Map[I mod 64] + Map[(I shr 6) mod 64] +
        Map[(I shr 12) mod 64] + Map[(I shr 18) mod 64]
  end
end;

function PostProcess(const S: AnsiString): AnsiString;
var
  SS: AnsiString;
begin
  SS := S;
  Result := '';
  while SS <> '' do
  begin
    Result := Result + Encode(Copy(SS, 1, 3));
    Delete(SS, 1, 3)
  end
end;

function InternalEncrypt(const S: AnsiString; Key: Word): AnsiString;
var
  I: Word;
  Seed: Word;
begin
  Result := S;
  Seed := Key;
  for I := 1 to Length(Result) do
  begin
    Result[I] := AnsiChar(Byte(Result[I]) xor (Seed shr 8));
    Seed := (Byte(Result[I]) + Seed) * Word(C1) + Word(C2)
  end
end;

function Encrypt(const S: AnsiString; Key: Word): AnsiString;
begin
  Result := PostProcess(InternalEncrypt(S, Key))
end;


function VarPos(sub,s: string; var vp: integer): integer;
begin
  vp := Pos(sub,s);
  Result := vp;
end;

procedure Split (const Delimiter: Char; Input: string; const Strings: TStrings);
begin
  Assert(Assigned(Strings));
  Strings.Clear;

  while pos(delimiter, input) > 0 do
  begin
    strings.Add(copy(input, 1, pos(delimiter, input) - 1));
    system.delete(input, 1, pos(delimiter, input));
  end;

  Strings.Add(input);
end;


function TCloudBase.SpaceEncode(const Url: string): string;
var
  i: Integer;
begin
  Result := '';
  for i := 1 to Length(Url) do
  begin
    case Url[i] of
      ' ':
        Result := Result + '%' + IntToHex(Ord(Url[i]), 2)
    else
        Result := Result + Url[i];
    end;
  end;

end;

class function TCloudBase.StrToInt64T(s: string): uint64;
var
  err: integer;
begin
  val(s,result,err);
end;

class function TCloudBase.StrToIntT(s: string): integer;
begin
  if not TryStrToInt(s, Result) then
    Result := 0;
end;

function TCloudBase.TestTokens: boolean;
begin
  Result := false;
end;


function TCloudBase.HTTPEncode(const AStr: ansistring): ansistring;
// The NoConversion set contains characters as specificed in RFC 1738 and
// should not be modified unless the standard changes.
const
  NoConversion = ['A'..'Z','a'..'z','*','@','.','_','-',
                  '0'..'9','$','!','''','(',')'];
var
  Sp, Rp: PAnsiChar;
begin
  SetLength(Result, Length(AStr) * 3);
  Sp := PAnsiChar(AStr);
  Rp := PAnsiChar(Result);
  while Sp^ <> #0 do
  begin
    if Sp^ in NoConversion then
      Rp^ := Sp^
    else
      if Sp^ = ' ' then
        Rp^ := '+'
      else
      begin
        FormatBuf(Rp^, 3, AnsiString('%%%.2x'), 6, [Ord(Sp^)]);
        Inc(Rp,2);
      end;
    Inc(Rp);
    Inc(Sp);
  end;
  SetLength(Result, Rp - PAnsiChar(Result));
end;

function TCloudBase.URLEncode(const Url: string): string;
var
  i: Integer;
  UrlA: ansistring;
  res: ansistring;
begin
  res := '';
  UrlA := ansistring(UTF8Encode(Url));

  for i := 1 to Length(UrlA) do
  begin
    case UrlA[i] of
      'A'..'Z', 'a'..'z', '0'..'9', '-', '_', '.':
        res := res + UrlA[i];
    else
        res := res + '%' + ansistring(IntToHex(Ord(UrlA[i]), 2));
    end;
  end;

  Result := string(res);
end;


function TCloudBase.URLEncodeTilde(const Url: string): string;
var
  i: Integer;
begin
  Result := '';
  for i := 1 to Length(Url) do
  begin
    case Url[i] of
      'A'..'Z', 'a'..'z', '0'..'9', '-', '_', '.','~':
        Result := Result + Url[i];
    else
        Result := Result + '%' + IntToHex(Ord(Url[i]), 2);
    end;
  end;
end;


function TCloudBase.URLEncodeRFC3986(URL: string): string;
var
  URL1: string;
begin
  URL1 := UrlEncode(URL);
  URL1 := StringReplace(URL1, '+', ' ', [rfReplaceAll, rfIgnoreCase]);
  Result := URL1;
end;


function DateTimeToUnix(ConvDate: TDateTime): Longint;
var
  x: double;
  lTimeZone: TTimeZoneInformation;
begin
  GetTimeZoneInformation(lTimeZone);
  ConvDate := ConvDate + (lTimeZone.Bias / 1440);
  x := (ConvDate - UnixStartDate) * 86400;
  Result := Trunc(x);
end;


function TCloudBase.GenerateTimeStamp: string;
begin
  Result := IntToStr(DateTimeToUnix(Now));
end;

function TCloudBase.GenerateNonce: string;
var
  md5: TIdHashMessageDigest;
  s: string;
begin
  s := IntToStr(GetTickCount);
  md5 := TIdHashMessageDigest5.Create;
//  Result := md5.HashStringAsHex(GenerateTimeStamp);
  Result := md5.HashStringAsHex(s);
  md5.Free;
end;

function TCloudBase.GenerateSignatureBase(url, consumerKey, httpMethod, timeStamp, nonce, signatureType, params: string): string;
var
  signaturebase: string;
begin
  signaturebase := Uppercase(httpmethod) + '&' + URLEncode(url) + '&' + URLEncode(params);
  Result := signaturebase;
end;

function TCloudBase.GetSignature(url: string; appsecret, tokensecret: string): string;
var
  signature, consec, contok: string;
begin
  contok := '';
  consec := URLEncodeRFC3986(appsecret) + '&';

  if tokensecret <> '' then
    consec := consec + URLEncodeRFC3986(tokensecret);

  signature := OAuthEncryptHMACSha1(url, consec);

  Result := signature;
end;

function TCloudBase.GetTokensAsString: string;
var
  s: string;
begin
  s := Token_Access + '&' +  Token_Auth + '&' + Token_Access_Secret + '&' +  Token_Auth_Secret + '&' + Token_Refresh;
  Result := string(Encrypt(ansistring(s),1995));
end;

function TCloudBase.GetVersion: string;
var
  vn: Integer;
begin
  vn := GetVersionNr;
  Result := IntToStr(Hi(Hiword(vn)))+'.'+IntToStr(Lo(Hiword(vn)))+'.'+IntToStr(Hi(Loword(vn)))+'.'+IntToStr(Lo(Loword(vn)));
end;

function TCloudBase.GetVersionNr: integer;
begin
  Result := MakeLong(MakeWord(BLD_VER,REL_VER),MakeWord(MIN_VER,MAJ_VER));
end;

function TCloudBase.GetOAuthSigBase(URL: string; Key: string; Method: string): string;
begin
  Result := Uppercase(Method)+ '&' + URLEncode(url) + '&' + URLEncode(RequestParamText);
end;

procedure TCloudBase.AddOAuthRequestParams(AppKey, AccessToken: string);
var
  TS,Nonce: string;
begin
  AddOAuthRequestParams(AppKey,AccessToken,TS,Nonce);
end;


procedure TCloudBase.RemoveOAuthRequestParams;
var
  i: integer;
begin
  if RequestParams.Count > 5 then
    for i := 0 to 5 do
      RequestParams.Delete(0);
end;

procedure TCloudBase.AddOAuthRequestParams(AppKey,AccessToken: string; var TS,Nonce: string);
begin
  TS := GenerateTimeStamp;
  Nonce := GenerateNonce;

  RequestParams.Clear;
  RequestParams.Values['oauth_consumer_key'] := AppKey;
  RequestParams.Values['oauth_nonce'] := Nonce;
  RequestParams.Values['oauth_signature_method'] := 'HMAC-SHA1';
  RequestParams.Values['oauth_timestamp'] := TS;
  RequestParams.Values['oauth_token'] := AccessToken;
  RequestParams.Values['oauth_version'] := '1.0';
end;

function TCloudBase.GetOAuthHeader(AppKey, AccessToken, TS, Nonce, Sig: string): string;
begin
  Result :=
    'oauth_consumer_key="'+ URLEncode(AppKey)+'",'
    + 'oauth_signature_method="HMAC-SHA1",'
    + 'oauth_timestamp="' + TS +'",'
    + 'oauth_nonce="' + Nonce + '",'
    + 'oauth_signature="' + UrlEncode(sig) +'",'
    + 'oauth_version="1.0",'
    + 'oauth_token="' + URLEncode(AccessToken)+'"';

  Result := 'OAuth ' + Result + #13#10;
end;

function TCloudBase.Base64Encode(const Input: TIdBytes): string;
begin
  Result := TIdEncoderMIME.EncodeBytes(Input)
end;

function TCloudBase.EncryptHMACSha1(Input, AKey: string): TIdBytes;
begin
  with TIdHMACSHA1.Create do
    try
      Key := ToBytes(AKey);
      Result := HashValue(ToBytes(Input));
    finally
      Free;
    end;
end;

function TCloudBase.OAuthEncryptHMACSha1(const value,key: string): string;
begin
  Result := Base64Encode(EncryptHMACSha1(Value, Key));
end;


function TCloudBase.ParseTokens(const jsonresult: ansistring; var Token,
  Secret: string): boolean;
const
  token_identifier: ansistring = 'oauth_token=';
  secret_identifier: ansistring = 'oauth_token_secret=';
  requestsplit: ansistring = '&';
var
  par: ansistring;
  idp: integer;
begin
  Token := '';
  Secret := '';

  idp := pos(token_identifier, jsonresult);
  if idp > 0 then
  begin
    par := jsonresult;
    System.Delete(par, 1, idp - 1 + length(token_identifier));
    Token := string(copy(par, 1, pos(requestsplit, par) - 1));
  end;

  idp := pos(secret_identifier, jsonresult);
  if idp > 0 then
  begin
    par := jsonresult;
    System.Delete(par, 1, idp - 1 + length(secret_identifier));
    Secret := string(copy(par, 1, pos(requestsplit, par) - 1));
  end;

  Result := (Token <> '') and (Secret <> '');
end;

function TCloudBase.HttpError(ErrorCode:Cardinal): string;
const
   winetdll = 'wininet.dll';
var
  Len: Integer;
  Buffer: PChar;
begin
  Len := FormatMessage(
  FORMAT_MESSAGE_FROM_HMODULE or FORMAT_MESSAGE_FROM_SYSTEM or
  FORMAT_MESSAGE_ALLOCATE_BUFFER or FORMAT_MESSAGE_IGNORE_INSERTS or  FORMAT_MESSAGE_ARGUMENT_ARRAY,
  Pointer(GetModuleHandle(winetdll)), ErrorCode, 0, @Buffer, SizeOf(Buffer), nil);
  try
    while (Len > 0) and {$IFDEF UNICODE}(CharInSet(Buffer[Len - 1], [#0..#32, '.'])) {$ELSE}(Buffer[Len - 1] in [#0..#32, '.']) {$ENDIF} do Dec(Len);
    SetString(Result, Buffer, Len);
  finally
    LocalFree(HLOCAL(Buffer));
  end;
end;

function TCloudBase.HttpsPost(const ServerName,Resource: String;Headers: TCoreCloudHeaders;const  PostData : AnsiString;Var Response:AnsiString): Integer;
const
  BufferSize = 1024*64;
var
  hInet: HINTERNET;
  hConnect: HINTERNET;
  hRequest: HINTERNET;
  ErrorCode: Integer;
  lpdwBufferLength: DWORD;
  lpdwReserved: DWORD;
  dwBytesRead: DWORD;
  //lpdwNumberOfBytesAvailable: DWORD;
  Buffer: array[0..1024] of AnsiChar;

  Header: string;
  I: Integer;
begin
  header := '';
  if Assigned(headers) then
  begin
    for I := 0 to Length(headers) - 1 do
      header := header + Headers[I].header + ': ' + headers[I].value;
  end;

  Log('HTTPS POST: '+ ServerName + Resource);
  Result := 0;
  Response := '';
  hInet := InternetOpen(PChar(FAgent), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);

  if hInet = nil then
  begin
    ErrorCode := GetLastError;
    raise Exception.Create(Format('InternetOpen Error %d Description %s',[ErrorCode,HttpError(ErrorCode)]));
  end;

  try
    hConnect := InternetConnect(hInet, PChar(ServerName), INTERNET_DEFAULT_HTTPS_PORT, nil, nil, INTERNET_SERVICE_HTTP, 0, 0);
    if hConnect=nil then
    begin
      ErrorCode := GetLastError;
      raise Exception.Create(Format('InternetConnect Error %d Description %s',[ErrorCode,HttpError(ErrorCode)]));
    end;

    try
      hRequest := HttpOpenRequest(hConnect, 'POST', PChar(Resource), HTTP_VERSION, '', nil, INTERNET_FLAG_SECURE, 0);
      if hRequest=nil then
      begin
        ErrorCode := GetLastError;
        raise Exception.Create(Format('HttpOpenRequest Error %d Description %s',[ErrorCode,HttpError(ErrorCode)]));
      end;

      try
        //send the post request
        if not HTTPSendRequest(hRequest, PChar(Header), Length(Header), @PostData[1], Length(PostData)) then
        begin
          ErrorCode := GetLastError;
          raise Exception.Create(Format('HttpSendRequest Error %d Description %s',[ErrorCode,HttpError(ErrorCode)]));
        end;

          lpdwBufferLength := SizeOf(Result);
          lpdwReserved := 0;
          //get the response code
          if not HttpQueryInfo(hRequest, HTTP_QUERY_STATUS_CODE or HTTP_QUERY_FLAG_NUMBER, @Result, lpdwBufferLength, lpdwReserved) then
          begin
            ErrorCode := GetLastError;
            raise Exception.Create(Format('HttpQueryInfo Error %d Description %s',[ErrorCode,HttpError(ErrorCode)]));
          end;

         //OutputDebugString(pchar(IntToStr(Result)));
         //if the response code = 200 then get the body
         //if (Result in [200,201]) or (Result = 401) then
         begin
           Response := '';
           FillChar(Buffer, SizeOf(Buffer), 0);
           repeat
             Response := Response + Buffer;
             FillChar(Buffer, SizeOf(Buffer), 0);
             InternetReadFile(hrequest, @Buffer, SizeOf(Buffer), dwBytesRead);
           until dwBytesRead = 0;
         end

          (*
          if InternetQueryDataAvailable(hRequest, lpdwNumberOfBytesAvailable, 0, 0) then
          begin


            //outputdebugstring(pchar('response size:'+inttostr(lpdwNumberOfBytesAvailable)));
            SetLength(Response,lpdwNumberOfBytesAvailable);
            InternetReadFile(hRequest, @Response[1], lpdwNumberOfBytesAvailable, dwBytesRead);

          end
          *)
//          else
//          begin
//            ErrorCode := GetLastError;
//            raise Exception.Create(Format('Http errror: %d ,InternetQueryDataAvailable Error %d Description %s',[Result,ErrorCode,HttpError(ErrorCode)]));
//          end;

      finally
        InternetCloseHandle(hRequest);
      end;
    finally
      InternetCloseHandle(hConnect);
    end;
  finally
    InternetCloseHandle(hInet);
  end;
end;

function TCloudBase.HttpsUpdate(const ServerName,Resource: String;Headers: TCoreCloudHeaders;const  PostData : AnsiString;Var Response:AnsiString): Integer;
const
  BufferSize = 1024*64;
var
  hInet: HINTERNET;
  hConnect: HINTERNET;
  hRequest: HINTERNET;
  ErrorCode: Integer;
  lpdwBufferLength: DWORD;
  lpdwReserved: DWORD;
  dwBytesRead: DWORD;
  //lpdwNumberOfBytesAvailable: DWORD;
  Buffer: array[0..1024] of AnsiChar;

  Header: string;
  I: Integer;
begin
  header := '';
  if Assigned(headers) then
  begin
    for I := 0 to Length(headers) - 1 do
      header := header + Headers[I].header + ': ' + headers[I].value;
  end;

  Log('HTTPS POST: '+ ServerName + Resource);
  Result := 0;
  Response := '';
  hInet := InternetOpen(PChar(FAgent), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);

  if hInet = nil then
  begin
    ErrorCode := GetLastError;
    raise Exception.Create(Format('InternetOpen Error %d Description %s',[ErrorCode,HttpError(ErrorCode)]));
  end;

  try
    hConnect := InternetConnect(hInet, PChar(ServerName), INTERNET_DEFAULT_HTTPS_PORT, nil, nil, INTERNET_SERVICE_HTTP, 0, 0);
    if hConnect=nil then
    begin
      ErrorCode := GetLastError;
      raise Exception.Create(Format('InternetConnect Error %d Description %s',[ErrorCode,HttpError(ErrorCode)]));
    end;

    try
      hRequest := HttpOpenRequest(hConnect, 'PUT', PChar(Resource), HTTP_VERSION, '', nil, INTERNET_FLAG_SECURE, 0);
      if hRequest=nil then
      begin
        ErrorCode := GetLastError;
        raise Exception.Create(Format('HttpOpenRequest Error %d Description %s',[ErrorCode,HttpError(ErrorCode)]));
      end;

      try
        //send the post request
        if not HTTPSendRequest(hRequest, PChar(Header), Length(Header), @PostData[1], Length(PostData)) then
        begin
          ErrorCode := GetLastError;
          raise Exception.Create(Format('HttpSendRequest Error %d Description %s',[ErrorCode,HttpError(ErrorCode)]));
        end;

          lpdwBufferLength := SizeOf(Result);
          lpdwReserved := 0;
          //get the response code
          if not HttpQueryInfo(hRequest, HTTP_QUERY_STATUS_CODE or HTTP_QUERY_FLAG_NUMBER, @Result, lpdwBufferLength, lpdwReserved) then
          begin
            ErrorCode := GetLastError;
            raise Exception.Create(Format('HttpQueryInfo Error %d Description %s',[ErrorCode,HttpError(ErrorCode)]));
          end;

         //if the response code = 200 then get the body
         //if (Result in [200,201]) or (Result = 401) then
         begin
           Response := '';
           FillChar(Buffer, SizeOf(Buffer), 0);
           repeat
             Response := Response + Buffer;
             FillChar(Buffer, SizeOf(Buffer), 0);
             InternetReadFile(hrequest, @Buffer, SizeOf(Buffer), dwBytesRead);
           until dwBytesRead = 0;
         end

          (*
          if InternetQueryDataAvailable(hRequest, lpdwNumberOfBytesAvailable, 0, 0) then
          begin
            //outputdebugstring(pchar('response size:'+inttostr(lpdwNumberOfBytesAvailable)));
            SetLength(Response,lpdwNumberOfBytesAvailable);
            InternetReadFile(hRequest, @Response[1], lpdwNumberOfBytesAvailable, dwBytesRead);
          end
          *)
//          else
//          begin
//            ErrorCode := GetLastError;
//            raise Exception.Create(Format('Http errror: %d ,InternetQueryDataAvailable Error %d Description %s',[Result,ErrorCode,HttpError(ErrorCode)]));
//          end;

      finally
        InternetCloseHandle(hRequest);
      end;
    finally
      InternetCloseHandle(hConnect);
    end;
  finally
    InternetCloseHandle(hInet);
  end;
end;

function TCloudBase.HttpsDelete(const ServerName,Resource: String; Headers: TCoreCloudHeaders;const  PostData : AnsiString;Var Response:AnsiString): Integer;
const
  BufferSize = 1024*64;
var
  hInet    : HINTERNET;
  hConnect : HINTERNET;
  hRequest : HINTERNET;
  ErrorCode : Integer;
  lpdwBufferLength: DWORD;
  lpdwReserved    : DWORD;
  dwBytesRead     : DWORD;
  lpdwNumberOfBytesAvailable: DWORD;
  Header: string;
  I: Integer;
begin
  header := '';
  if Assigned(headers) then
  begin
    for I := 0 to Length(headers) - 1 do
      header := header + Headers[I].header + ': ' + headers[I].value;
  end;
  Log('HTTPS DELETE: ' + ServerName + Resource);
  Result  :=0;
  Response:='';
  hInet := InternetOpen(PChar(FAgent), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);

  if hInet=nil then
  begin
    ErrorCode:=GetLastError;
    raise Exception.Create(Format('InternetOpen Error %d Description %s',[ErrorCode,HttpError(ErrorCode)]));
  end;

  try
    hConnect := InternetConnect(hInet, PChar(ServerName), INTERNET_DEFAULT_HTTPS_PORT, nil, nil, INTERNET_SERVICE_HTTP, 0, 0);
    if hConnect=nil then
    begin
      ErrorCode:=GetLastError;
      raise Exception.Create(Format('InternetConnect Error %d Description %s',[ErrorCode,HttpError(ErrorCode)]));
    end;

    try
      hRequest := HttpOpenRequest(hConnect, 'DELETE', PChar(Resource), 'HTTP/1.1', '', nil, INTERNET_FLAG_SECURE or INTERNET_FLAG_IGNORE_CERT_CN_INVALID, 0);
      if hRequest=nil then
      begin
        ErrorCode := GetLastError;
        raise Exception.Create(Format('HttpOpenRequest Error %d Description %s',[ErrorCode,HttpError(ErrorCode)]));
      end;

      try
        //send the post request
        //if not HTTPSendRequest(hRequest, PChar(Header), Length(Header), nil, 0) then
        if not HTTPSendRequest(hRequest, nil, 0, nil, 0) then
        begin
          ErrorCode := GetLastError;
          raise Exception.Create(Format('HttpSendRequest Error %d Description %s',[ErrorCode,HttpError(ErrorCode)]));
        end;

          lpdwBufferLength := SizeOf(Result);
          lpdwReserved := 0;
          //get the response code
          if not HttpQueryInfo(hRequest, HTTP_QUERY_STATUS_CODE or HTTP_QUERY_FLAG_NUMBER, @Result, lpdwBufferLength, lpdwReserved) then
          begin
            ErrorCode := GetLastError;
            raise Exception.Create(Format('HttpQueryInfo Error %d Description %s',[ErrorCode,HttpError(ErrorCode)]));
          end;

         //if the response code =200 then get the body
         if Result = 200 then
          if InternetQueryDataAvailable(hRequest, lpdwNumberOfBytesAvailable, 0, 0) then
          begin
            SetLength(Response,lpdwNumberOfBytesAvailable);
            InternetReadFile(hRequest, @Response[1], lpdwNumberOfBytesAvailable, dwBytesRead);
          end
          else
          begin
            ErrorCode := GetLastError;
            raise Exception.Create(Format('InternetQueryDataAvailable Error %d Description %s',[ErrorCode,HttpError(ErrorCode)]));
          end;

      finally
        InternetCloseHandle(hRequest);
      end;
    finally
      InternetCloseHandle(hConnect);
    end;
  finally
    InternetCloseHandle(hInet);
  end;
end;

function TCloudBase.HttpsGet(const Url: string;FileName: string; Size: int64): ansistring;
var
  NetHandle: HINTERNET;
  UrlHandle: HINTERNET;
  Buffer: array[0..1024] of AnsiChar;
  BytesRead: dWord;
  memst: TMemoryStream;
  position: int64;
begin
  Log('HTTPS GET: ' + URL);
  NetHandle := InternetOpen(PChar(FAgent), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
  if Assigned(NetHandle) then
  begin
    UrlHandle := InternetOpenUrl(NetHandle, PChar(Url), nil, 0, INTERNET_FLAG_RELOAD, 0);

    position := 0;

    if Assigned(UrlHandle) then
      { UrlHandle valid? Proceed with download }
    begin
      memst := TMemoryStream.Create;

      try
        FillChar(Buffer, SizeOf(Buffer), 0);
        repeat
          FillChar(Buffer, SizeOf(Buffer), 0);
          InternetReadFile(UrlHandle, @Buffer, SizeOf(Buffer), BytesRead);

          memst.Write(buffer, bytesread);

          position := position + bytesread;

          DoDownloadProgress(URL,position,Size);

        until BytesRead = 0;

      finally
        memst.SaveToFile(FileName);
        memst.Free;
      end;

      InternetCloseHandle(UrlHandle);
    end
    else
      { UrlHandle is not valid. Raise an exception. }
      raise Exception.CreateFmt('Cannot open URL %s', [Url]);

    InternetCloseHandle(NetHandle);
  end
  else
    { NetHandle is not valid. Raise an exception }
    raise Exception.Create('Unable to initialize Wininet');
end;

function TCloudBase.HttpsGet(const Url: string; Stream: TMemoryStream; Size: int64): ansistring;
var
  NetHandle: HINTERNET;
  UrlHandle: HINTERNET;
  Buffer: array[0..1024] of AnsiChar;
  BytesRead: dWord;
  position: int64;

begin
  Log('HTTPS GET: ' + URL);
  NetHandle := InternetOpen(PChar(FAgent), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
  if Assigned(NetHandle) then
  begin
    UrlHandle := InternetOpenUrl(NetHandle, PChar(Url), nil, 0, INTERNET_FLAG_RELOAD, 0);

    position := 0;

    if Assigned(UrlHandle) then
      { UrlHandle valid? Proceed with download }
    begin
      try
        FillChar(Buffer, SizeOf(Buffer), 0);
        repeat
          FillChar(Buffer, SizeOf(Buffer), 0);
          InternetReadFile(UrlHandle, @Buffer, SizeOf(Buffer), BytesRead);
          Stream.Write(buffer, bytesread);

          position := position + bytesread;

          DoDownloadProgress(URL,position,Size);

        until BytesRead = 0;
      finally
      end;
      InternetCloseHandle(UrlHandle);
    end
    else
      { UrlHandle is not valid. Raise an exception. }
      raise Exception.CreateFmt('Cannot open URL %s', [Url]);

    InternetCloseHandle(NetHandle);
  end
  else
    { NetHandle is not valid. Raise an exception }
    raise Exception.Create('Unable to initialize Wininet');
end;


function TCloudBase.HttpsGet(const Url: string): ansistring;
begin
  Result := HttpsGet(URL,nil);
end;


function TCloudBase.HttpsGet(const Url: String; Headers: TCoreCloudHeaders): ansistring;
var
  NetHandle: HINTERNET;
  UrlHandle: HINTERNET;
  Buffer: array[0..1024] of AnsiChar;
  BytesRead: dWord;
  Header: string;
  I: Integer;
begin
  header := '';
  if Assigned(headers) then
  begin
    for I := 0 to Length(headers) - 1 do
      header := header + Headers[I].header + ': ' + headers[I].value;
  end;

  Log('HTTPS GET: ' + URL);
  Result := '';
  NetHandle := InternetOpen(PChar(FAgent), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);

  if Assigned(NetHandle) then
  begin
    if Header <> '' then
      UrlHandle := InternetOpenUrl(NetHandle, PChar(Url), PChar(Header), Length(Header), INTERNET_FLAG_RELOAD, 0)
    else
      UrlHandle := InternetOpenUrl(NetHandle, PChar(Url), nil, 0, INTERNET_FLAG_RELOAD, 0);

    if Assigned(UrlHandle) then
    begin
      repeat
        BytesRead := 0;
        InternetReadFile(UrlHandle, @Buffer, SizeOf(Buffer) - 1, BytesRead);
        buffer[BytesRead] := #0;
        Result := Result + buffer;
      until (BytesRead = 0);
      InternetCloseHandle(UrlHandle);
    end
    else
      raise Exception.CreateFmt('Cannot open URL %s', [Url]);

    InternetCloseHandle(NetHandle);
  end
  else
    raise Exception.Create('Unable to initialize Wininet');
end;


procedure EncodePacket(const Packet: TPacket; NumChars: Integer; OutBuf: PChar);
begin
  OutBuf[0] := EnCodeTable[Packet.a[0] shr 2];
  OutBuf[1] := EnCodeTable[((Packet.a[0] shl 4) or (Packet.a[1] shr 4)) and $0000003f];

  if NumChars < 2 then
    OutBuf[2] := '='
  else
    OutBuf[2] := EnCodeTable[((Packet.a[1] shl 2) or (Packet.a[2] shr 6)) and $0000003f];

  if NumChars < 3 then
    OutBuf[3] := '='
  else
    OutBuf[3] := EnCodeTable[Packet.a[2] and $0000003f];
end;

function DecodePacket(InBuf: PChar; var nChars: Integer): TPacket;
begin
  Result.a[0] := (DecodeTable[InBuf[0]] shl 2) or
    (DecodeTable[InBuf[1]] shr 4);
  NChars := 1;
  if InBuf[2] <> '=' then
  begin
    Inc(NChars);
    Result.a[1] := (DecodeTable[InBuf[1]] shl 4) or (DecodeTable[InBuf[2]] shr 2);
  end;
  if InBuf[3] <> '=' then
  begin
    Inc(NChars);
    Result.a[2] := (DecodeTable[InBuf[2]] shl 6) or DecodeTable[InBuf[3]];
  end;
end;

function Base64Decode(const Input: string): string;
var
  I, J, K: Integer;
  Packet: TPacket;
begin
  Result := '';
  for I := 1 to Length(Input) div 4 do
  begin
    Packet := DecodePacket(PChar(@Input[(I - 1) * 4 + 1]), J);
    K := 0;
    while J > 0 do
    begin
      Result := Result + Packet.c[K];
      Inc(K);
      Dec(J);
    end;
  end;
end;



function Base64Encode(const Input: TIdBytes): string;
begin
  Result := TIdEncoderMIME.EncodeBytes(Input)
end;

function EncryptHMACSha1(Input, AKey: string): TIdBytes;
begin
  with TIdHMACSHA1.Create do
    try
      Key := ToBytes(AKey);
      Result := HashValue(ToBytes(Input));
    finally
      Free;
    end;
end;

function OAuthEncryptHMACSha1(const value,key: string): string;
begin
  Result := Base64Encode(EncryptHMACSha1(Value, Key));
end;

function URLtoFile(url:string): string;
begin
  while Pos('/',url) > 0 do
    Delete(url,1,Pos('/',url));
  while Pos('\',url) > 0 do
   Delete(url,1,pos('\',url));
  Result := url;
end;


function AddFileToDir(Dir,fn:string):string;
begin
  if Length(Dir) > 0 then
  begin
    if Dir[Length(dir)] = '\' then
      Result := dir + fn
    else
      Result := dir + '\' + fn;
  end
  else
    Result := fn;
end;

function TCloudBase.CleanUpJSON(Value: ansistring): ansistring;
const
  JSONStart: ansistring = '{';
  JSONEnd: ansistring = '}';
var
  i: integer;
  res: ansistring;

begin
  res := Value;
  i := Pos(JSONStart,res);

  // trim first chars
  if i > 1 then
    System.Delete(res,1,i - 1);

  i := length(res);

  while (i > 1) and (res[i] <> JSONEnd) do
  begin
    dec(i);
  end;

  System.Delete(res,i + 1, length(res) - i);

  Result := res;
end;

procedure TCloudBase.CloseOAuthForm;
begin
  if Assigned(FOAuthForm) then
    FOAuthForm.Close;
end;

constructor TCloudBase.Create(AOwner: TComponent);
begin
  inherited;
  FAgent := 'Mozilla/5.001 (windows; U; NT4.0; en-US; rv:1.0) Gecko/25250101';
  FRequestParams := TStringList.Create;
  FAuthFormSettings := TAuthFormSettings.Create;
  FScopes := TStringList.Create;
  FOAuthForm := nil;
  FLogging := false;
  FLogFileName := ClassName + '.LOG';
  FPersistTokens := TPersistTokens.Create;
  FApp := TCloudApp.Create;
  FLocale := lcDefault;
end;

function TCloudBase.CreateOAuthForm(url: string; CallBack: TWebBrowserBeforeNavigate2; CallBackComplete: TWebBrowserNavigateComplete2): TForm;
var
  wb: TWebBrowser;
begin
  FOAuthForm := TForm.CreateNew(nil);
  wb := TWebBrowser.Create(FOAuthForm);
  wb.Align := alClient;
  wb.SetParentComponent(FOAuthForm);
  wb.Navigate(url);
  wb.OnBeforeNavigate2 := CallBack;
  wb.OnNavigateComplete2 := CallBackComplete;
  FOAuthForm.Width := AuthFormSettings.Width;
  FOAuthForm.Height := AuthFormSettings.Height;
  FOAuthForm.Caption := AuthFormSettings.Caption;
  FOAuthForm.Position := poScreenCenter;
  FOAuthForm.OnClose := DoFormClose;
  FOAuthForm.ShowModal;
  Result := FOAuthForm;
end;


function IntToZStr(i,l: Integer):string;
var
  Res: string;
begin
  Res := IntToStr(i);
  while Length(Res)<l do
    Res := '0' + Res;

  Result := Res;
end;

function TCloudBase.DateTimeToIso(dt: TDateTime): string;
var
  da,mo,ye,ho,mi,se,ms:word;
begin
  DecodeDate(dt,ye,mo,da);
  DecodeTime(dt,ho,mi,se,ms);
  Result := IntToStr(ye) + IntToZStr(mo,2) + IntToZStr(da,2) + 'T' +
            IntToZStr(ho,2) + IntToZStr(mi,2) + IntToZStr(se,2);
end;

function TCloudBase.DateTimeToWL(dt: TDateTime): string;
var
  da,mo,ye,ho,mi,se,ms:word;
  lTimeZone: TTimeZoneInformation;
  tz : TTimeZoneInformation;
begin
  GetTimeZoneInformation(lTimeZone);

  DecodeDate(dt,ye,mo,da);
  DecodeTime(dt,ho,mi,se,ms);
  Result := IntToStr(ye) + '-' + IntToZStr(mo,2) + '-' + IntToZStr(da,2) + 'T' +
            IntToZStr(ho,2) + ':' + IntToZStr(mi,2) + ':' + IntToZStr(se,2) + '+';

  case GetTimeZoneInformation(tz) of
    TIME_ZONE_ID_STANDARD: Result := Result + IntToZStr((- lTimeZone.Bias) div 60,2) + ':00';
    TIME_ZONE_ID_DAYLIGHT: Result := Result + IntToZStr((- lTimeZone.Bias - lTimeZone.DaylightBias) div 60,2) + ':00';
  else
    Result := Result + '00:00';
  end;
end;

function TCloudBase.DateToWL(d: TDate): string;
var
  da,mo,ye:word;
begin
  DecodeDate(d,ye,mo,da);
  Result := IntToStr(ye) + '-' + IntToZStr(mo,2) + '-' + IntToZStr(da,2) + 'T00:00:00Z';
end;

destructor TCloudBase.Destroy;
begin
  if Assigned(FOAuthForm) then
    FOAuthForm.Free;

  FScopes.Free;
  FAuthFormSettings.Free;
  FRequestParams.Free;
  FPersistTokens.Free;
  FApp.Free;
  inherited;
end;

procedure TCloudBase.DoAuth;
begin
  //
end;

procedure TCloudBase.DoDownloadProgress(Filename: string; position,
  total: int64);
begin
  if Assigned(OnDownloadProgress) then
    OnDownloadProgress(Self,FileName,position,total);
  Application.ProcessMessages;
end;

procedure TCloudBase.DoFormClose(Sender: TObject; var Action: TCloseAction);
begin
  if Assigned(FOnAuthFormClose) then
    FOnAuthFormClose(Self);
end;

procedure TCloudBase.DoReceivedAccessToken;
begin
  if Assigned(OnReceivedAccessToken) then
    OnReceivedAccessToken(Self);
end;

procedure TCloudBase.DoUploadProgress(Filename: string; position, total: int64);
begin
  if Assigned(OnUploadProgress) then
    OnUploadProgress(Self,FileName,position,total);
  Application.ProcessMessages;
end;

function TCloudBase.ExtractServer(url:string): string;
var
  atpos,slpos: integer;
begin
  if Pos('://',UpperCase(url)) > 0 then
    Delete(url,1,Pos('://',url) + 2);

  atpos := Pos('@',UpperCase(url));
  slpos := Pos('/',UpperCase(url));

  if (atpos > 0) and (atpos < slpos) then
    Delete(url,1,Pos('@',url) + 1);

  if Pos('/',url) > 0 then
    url := Copy(url,1,Pos('/',url)-1);

  Result := url;
end;

function TCloudBase.RefreshAccess: boolean;
begin
  Result := false;
end;

function TCloudBase.RemoveServer(url:string): string;
begin
  if Pos('://',UpperCase(url)) > 0 then
    Delete(url,1,Pos('://',url) + 2);

  if Pos('@',UpperCase(url)) > 0 then
    Delete(url,1,Pos('@',url) + 1);

  if Pos('/',url) > 0 then
    Delete(url,1,Pos('/',url)-1);

  Result := url;
end;

function TCloudBase.RequestParamText: string;
var
  i: integer;
begin
  Result := '';
  for i := 0 to RequestParams.Count - 1 do
  begin
    if i > 0 then
      Result := Result + '&' + RequestParams.Strings[i]
    else
      Result := RequestParams.Strings[i]
  end;
end;

procedure TCloudBase.ClearTokens;
begin
  Token_Access := '';
  Token_Auth := '';
  Token_Access_Secret := '';
  Token_Auth_Secret := '';
  Token_Refresh := '';
  SaveTokens;
end;

procedure TCloudBase.SaveTokens;
var
  Settings: TIniFile;
  RegInifile: TReginifile;
begin
  if (PersistTokens.Key = '') or (PersistTokens.Section = '') then
    Exit;

  case PersistTokens.Location of
  plIniFile:
    begin
      Settings := TIniFile.Create(PersistTokens.Key);

      Settings.WriteString(PersistTokens.Section,'ACCESS_TOKEN',string(Encrypt(AnsiString(Token_Access),1969)));
      Settings.WriteString(PersistTokens.Section,'AUTH_TOKEN',string(Encrypt(AnsiString(Token_Auth),1969)));
      Settings.WriteString(PersistTokens.Section,'ACCESS_TOKEN_SECRET',string(Encrypt(AnsiString(Token_Access_Secret),1969)));
      Settings.WriteString(PersistTokens.Section,'AUTH_TOKEN_SECRET',string(Encrypt(AnsiString(Token_Auth_Secret),1969)));
      Settings.WriteString(PersistTokens.Section,'REFRESH_TOKEN',string(Encrypt(AnsiString(Token_Refresh),1969)));

      Settings.Free;
    end;
  plRegistry:
    begin
      RegIniFile := TRegIniFile.Create(PersistTokens.Key);

      RegIniFile.WriteString(PersistTokens.Section,'ACCESS_TOKEN',string(Encrypt(AnsiString(Token_Access),1969)));
      RegIniFile.WriteString(PersistTokens.Section,'AUTH_TOKEN',string(Encrypt(AnsiString(Token_Auth),1969)));
      RegIniFile.WriteString(PersistTokens.Section,'ACCESS_TOKEN_SECRET',string(Encrypt(AnsiString(Token_Access_Secret),1969)));
      RegIniFile.WriteString(PersistTokens.Section,'AUTH_TOKEN_SECRET',string(Encrypt(AnsiString(Token_Auth_Secret),1969)));
      RegIniFile.WriteString(PersistTokens.Section,'REFRESH_TOKEN',string(Encrypt(AnsiString(Token_Refresh),1969)));

      RegIniFile.Free;
    end;
  end;
end;

function TCloudBase.ScopeParamText(Delimiter: string; Encode: boolean = false): string;
var
  i: integer;
  scopestr: string;
begin
  Result := '';
  for i := 0 to Scopes.Count - 1 do
  begin
    if Encode then
      scopestr := URLEncode(Scopes[i])
    else
      scopestr := Scopes[i];

    if Result = '' then
      Result := scopestr
    else
      Result := Result + Delimiter + scopestr;
  end;
end;

procedure TCloudBase.SetApp(const Value: TCloudApp);
begin
  FApp.Assign(Value);
end;

procedure TCloudBase.SetAuthFormSettings(const Value: TAuthFormSettings);
begin
  FAuthFormSettings.Assign(Value);
end;

procedure TCloudBase.SetPersistTokens(const Value: TPersistTokens);
begin
  FPersistTokens.Assign(Value);
end;

procedure TCloudBase.SetScopes(const Value: TStrings);
begin
  FScopes.Assign(Value);
end;

procedure TCloudBase.SetTokensAsString(const Value: string);
var
  s: string;
begin
  s := string(Decrypt(ansistring(Value),1995));

  FToken_Access := Copy(s,1,Pos('&',s) - 1);
  Delete(s,1,Pos('&',s) + 1);
  FToken_Auth := Copy(s,1,Pos('&',s) - 1);
  Delete(s,1,Pos('&',s) + 1);
  FToken_Access_Secret := Copy(s,1,Pos('&',s) - 1);
  Delete(s,1,Pos('&',s) + 1);
  FToken_Auth_Secret := Copy(s,1,Pos('&',s) - 1);
  Delete(s,1,Pos('&',s) + 1);
  FToken_Refresh := s;
end;

function TCloudBase.SignURL(url: string): string;
var
  i: integer;
begin
  Result := url;
  for i := 0 to RequestParams.Count - 1 do
  begin
    if i > 0 then
      Result := Result + '&' + RequestParams.Strings[i]
    else
      Result := Result + '?' + RequestParams.Strings[i];
  end;
end;

function TCloudBase.EncodeParams(Params: TStringList; splitter: String;
  quot: Boolean; encodeHttp: Boolean = false): string;
var
  arr: TStringList;
  buf: string;
  I: Integer;

begin
  arr := TStringList.Create;
  arr.Clear;

  for I := 0 to Params.Count - 1 do
  begin
    begin
      if quot then
        buf := Params.Names[I] + '="' + Params.ValueFromIndex[I] + '"'
      else
      begin
        if encodeHttp then
          buf := Params.Names[I] + '=' +
            String(HTTPEncode(UTF8Encode(Params.ValueFromIndex[I]))) + ''
        else
          buf := Params.Names[I] + '=' + UrlEncode
            (String(UTF8Encode(Params.ValueFromIndex[I]))) + '';
      end;
      arr.Add(buf);
    end;
  end;

  if not quot then
    arr.Sort;

  buf := '';

  for I := 0 to arr.Count - 1 do
  begin
    if (buf <> '') then
      buf := buf + splitter;
    buf := buf + arr.Strings[I];
  end;
  arr.Free;
  Result := buf;
end;

function TCloudBase.HttpsPut(url,tgtdir,tgtfn: String;customheaders: TCoreCloudHeaders; customdata: ansistring; HttpCommand: THTTPCommand): ansistring;
var
  buf:array[0..READBUFFERSIZE - 1] of char;
  buffer: array[0..READBUFFERSIZE - 1] of ansichar;
  bufsize:dword;
  lf: File;
  fn,furl,fsrvr:string;
  fsize,totsize,position:int64;
  hconnect:hinternet;
  hintfile:hinternet;
  lpdword:dword;
  bufferin:INTERNET_BUFFERS;
  BytesRead: dword;
  fm: word;
  FHinternet: hinternet;
  header: string;
  hdrs: string;
  head,headbound: ansistring;
  tail: ansistring;

  customheader: string;
  I: Integer;
begin
  customheader := '';
  if Assigned(customheaders) then
  begin
    for I := 0 to Length(customheaders) - 1 do
      customheader := customheader + customheaders[I].header + ': ' + customheaders[I].value;
  end;

  Log('HTTPS PUT: ' + URL);
  Result := '';

  head := '';
  tail := '';
  headbound := '';

  FUrl := url;

  fn := UrlToFile(url);

  if tgtfn <> '' then
    fn := tgtfn
  else
    fn := URLtoFile(url);

  fn := AddFileToDir(tgtdir,fn);
  if not FileExists(fn) then
    Exit;

  fsrvr := ExtractServer(url);

  url := RemoveServer(url);

  FHinternet := InternetOpen(PChar(FAgent), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);

  hconnect := InternetConnect(FHinternet,PChar(fsrvr),INTERNET_DEFAULT_HTTPS_PORT,nil,nil,INTERNET_SERVICE_HTTP,0,0);

  if (HttpCommand in [hcPost, hcPostMultiPart]) then
    hintfile := HttpOpenRequest(HConnect,'POST',PChar(url),'HTTP/1.1',nil,nil,INTERNET_FLAG_SECURE or INTERNET_FLAG_NO_CACHE_WRITE ,0)
  else
    hintfile := HttpOpenRequest(HConnect,'PUT',PChar(url),'HTTP/1.1',nil,nil,INTERNET_FLAG_SECURE or INTERNET_FLAG_NO_CACHE_WRITE ,0);

  if hintfile = nil then
  begin
    Exit;
  end;

  bufsize := READBUFFERSIZE;

  fm := FileMode;
  FileMode := 0; // openread mode

  if hintfile <> nil then
  begin
    AssignFile(lf,fn);
    Reset(lf,1);
    TotSize := FileSize(lf);

    //********************* HEADER RELATED
    if HttpCommand = hcPost then
    begin
      hdrs := customheader;
      if hdrs <> '' then
        HttpAddRequestHeaders(hintfile, pchar(hdrs), length(hdrs), HTTP_ADDREQ_FLAG_ADD);

      header := 'Content-Length: '+ inttostr(totsize);
      HttpAddRequestHeaders(hintfile, pchar(header), length(header), HTTP_ADDREQ_FLAG_ADD or HTTP_ADDREQ_FLAG_REPLACE);

      header := 'Content-Type: application/octet-stream';
      HttpAddRequestHeaders(hintfile, pchar(header), length(header), HTTP_ADDREQ_FLAG_ADD or HTTP_ADDREQ_FLAG_REPLACE);

      header := 'Content-Transfer-Encoding: binary';
      HttpAddRequestHeaders(hintfile, pchar(header), length(header), HTTP_ADDREQ_FLAG_ADD or HTTP_ADDREQ_FLAG_REPLACE);
    end;

    if (HttpCommand = hcPut)  then
    begin
      if customheader <> '' then
      begin
        hdrs := customheader;
        HttpAddRequestHeaders(hintfile, pchar(hdrs), length(hdrs), HTTP_ADDREQ_FLAG_ADD );
      end;

      hdrs := 'Content-Length: '+ inttostr(totsize);
      HttpAddRequestHeaders(hintfile, pchar(hdrs), length(hdrs), HTTP_ADDREQ_FLAG_ADD );

      hdrs := 'Content-Type: application/octet-stream';
      HttpAddRequestHeaders(hintfile, pchar(hdrs), length(hdrs), HTTP_ADDREQ_FLAG_ADD );

      hdrs := 'Content-Transfer-Encoding: binary';
      HttpAddRequestHeaders(hintfile, pchar(hdrs), length(hdrs), HTTP_ADDREQ_FLAG_ADD);
    end;

(* *)
    if (HttpCommand in [hcPostMultiPart, hcPutMultiPart]) then
    begin
      headbound := '--AaB03x'#13#10;
      tail := #13#10'--AaB03x--'#13#10;

      hdrs := ''
          + customheader
          +'Content-Type: multipart/form-data; boundary=AaB03x'#13#10
          + #13#10;

      HttpAddRequestHeaders(hintfile, pchar(hdrs), length(hdrs), HTTP_ADDREQ_FLAG_ADD);
    end;
(* *)

    //********************* DATA RELATED

    FillChar(bufferin, SizeOf(bufferin),0);
    bufferin.dwStructSize := SizeOf(INTERNET_BUFFERS);
    bufferin.dwBufferTotal := length(headbound) + length(customdata) + TotSize + length(tail);

    if not HttpSendRequestEx(hintfile,@bufferin,nil,HSR_INITIATE,0) then
    begin
      FLastError := GetLastError;
      CloseFile(lf);
      InternetCloseHandle(hintfile);
      InternetCloseHandle(hconnect);
      Exit;
    end;

    if (HttpCommand in [hcPutMultiPart, hcPostMultiPart]) and (headbound <> '') then
      InternetWriteFile(hintfile,pansichar(@headbound[1]),length(headbound),lpdword);

    if (HttpCommand in [hcPutMultiPart, hcPostMultiPart]) and (customdata <> '') then
      InternetWriteFile(hintfile,pansichar(@customdata[1]),length(customdata),lpdword);

    bufsize := READBUFFERSIZE;
    FSize := 0;
    position := 0;

    while (bufsize = READBUFFERSIZE) do
    begin
      BlockRead(lf,buf,READBUFFERSIZE,bufsize);

      if not InternetWriteFile(hintfile,@buf,bufsize,lpdword) then
      begin
        FLastError := GetLastError;
        Break;
      end;

      FSize := FSize + bufsize;
      position := position + lpdword;
      DoUploadProgress(fn,position,totsize);
    end;

    if (HttpCommand in [hcPutMultiPart, hcPostMultiPart]) then
      InternetWriteFile(hintfile,pansichar(@tail[1]),length(tail),lpdword);

    if not HttpEndRequest(hintfile,nil,0,0) then
    begin
      FLastError := GetLastError;
    end;

    CloseFile(lf);

    // read response
    FillChar(BufFer, SizeOf(Buffer), 0);
    repeat
      Result := Result + Buffer;
      FillChar(Buffer, SizeOf(Buffer), 0);
      InternetReadFile(hintfile, @Buffer, SizeOf(Buffer), BytesRead);
    until BytesRead = 0;

    InternetCloseHandle(hintfile);
    InternetCloseHandle(hconnect);
    InternetCloseHandle(FHinternet);

    FileMode := fm;
  end;
end;

function TCloudBase.GetJSONValue(URL, ID: string): string;
var
  o: TJSONObject;
  p: TJSONPair;

begin
  o := GetJSONObject(URL);
  if Assigned(o) then
  begin
    p := o.Get(ID);
    if Assigned(p) then
    begin
      Result := p.JsonValue.Value;
    end;
    o.Free;
  end;
end;

class function TCloudBase.GetJSONValue(O: TJSONObject; ID: string): TJSONValue;
var
  p: TJSONPair;
begin
  Result := nil;
  p := o.Get(ID);
  if Assigned(p) then
  begin
    Result := p.JsonValue;
  end;
end;

function TCloudBase.GetMimeType(FileName: string): string;
var
  reg: TRegistry;
  ext: string;
begin
  Result := '';

  reg := TRegistry.Create;
  try
    ext := ExtractFileExt(Filename);
    reg.RootKey := HKEY_LOCAL_MACHINE;
    if reg.OpenKeyReadOnly('\SOFTWARE\Classes\'+ext+'\') then
    begin
      Result := reg.ReadString('Content Type');
    end;
  finally
    reg.Free;
  end;

  if Result = '' then
    Result := 'application/octet-stream';
end;

class function TCloudBase.GetJSONProp(O: TJSONOBject; ID: string): string;
var
  p: TJSONPair;
begin
  Result := '';
  p := o.Get(ID);
  if Assigned(p) then
    Result := p.JsonValue.Value;
end;

class function TCloudBase.GetJSONProp(JSON: string; ID: string): string;
var
  StringBytes: TBytes;
  o: TJSONObject;
  p: TJSONPair;

begin
  Result := '';

  StringBytes := TEncoding.ASCII.GetBytes(JSON);

  o := TJSONObject.Create;

  try
    o.Parse(StringBytes,0);
    p := o.Get(ID);
    if Assigned(p) then
    begin
      Result := p.JsonValue.Value;
    end;
  finally
    o.Free;
  end;
end;

function TCloudBase.GetJSONObject(URL: string): TJSONObject;
var
  jv: TJSONValue;
  sl: TStringList;
  st: TMemoryStream;
  sa: ansistring;
begin
  st := TMemoryStream.Create;
  sl := TStringList.Create;
  try
    HttpsGet(URL,st, 0);
    st.Position := 0;
    sl.LoadFromStream(st);
    sa := ansistring(sl.Text);
    jv := TJSONOBject.ParseJSONValue(UTF8ToString(sa));
    Result := jv as TJSONObject;
  finally
    sl.Free;
    st.Free;
  end;
end;


class function TCloudBase.LongDateStrToDateTime(const s: string): TDateTime;
const
  months: array[1..12] of string = ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');
var
  res,mostr,dastr,yestr: string;
  da,ye,mo: word;
  i,err: integer;
  ts: char;
begin

  //format to handle 'Mon May 16 20:07:59 +0000 2011';
  res := s;
  delete(res,1,4);
  mostr := copy(res,1,3);
  yestr := copy(res,length(res) -3,4);

  mo := 1;
  for i := 1 to 12 do
  begin
    if mostr = months[i] then
    begin
      mo := i;
      break;
    end;
  end;

  delete(res,1,4);
  dastr := Trim(copy(res,1,2));

  val(dastr,da,err);
  val(yestr,ye,err);

  delete(res,1,pos(' ',res));

  ts := FormatSettings.TimeSeparator;
  FormatSettings.TimeSeparator := ':';

  try
    res := copy(res,1,8);
    Result := EncodeDate(ye,mo,da) + StrToTime(res);
  finally
    FormatSettings.TimeSeparator := ts;
  end;
end;


class function TCloudBase.IsoToDateTime(const s: string):TDateTime;
var
  da,mo,ye,ho,mi,se: Word;
  err: Integer;
begin
  Val(Copy(s,1,4),ye,err);
  Val(Copy(s,6,2),mo,err);
  Val(Copy(s,9,2),da,err);
  Val(Copy(s,12,2),ho,err);
  Val(Copy(s,15,2),mi,err);
  Val(Copy(s,18,2),se,err);
  Result := EncodeDate(ye,mo,da) + EncodeTime(ho,mi,se,0);
end;

class function TCloudBase.IsoToDate(const s: string):TDateTime;
var
  da,mo,ye: Word;
  err: Integer;
begin
  Val(Copy(s,1,4),ye,err);
  Val(Copy(s,6,2),mo,err);
  Val(Copy(s,9,2),da,err);
  Result := EncodeDate(ye,mo,da) + EncodeTime(0,0,0,0);
end;

procedure FreePidl( pidl: PItemIDList );
var
  allocator: IMalloc;
begin
  if Succeeded(SHGetMalloc(allocator)) then
    allocator.Free(pidl);
end;


function UserDocDir: string;
var
  pidl: PItemIDList;
  Path: array [0..MAX_PATH-1] of char;
begin
  Result := '';

  if Succeeded(
       SHGetSpecialFolderLocation(Application.Handle, CSIDL_PERSONAL, pidl)
     ) then
  begin
    if SHGetPathFromIDList(pidl, Path) then
      Result := Strpas(path);
    FreePidl(pidl);
  end;
end;


function AddBackslash(const s: string): string;
begin
  if (Length(s) >= 1) and (s[Length(s)]<>'\') then
    Result := s + '\'
  else
    Result := s;
end;


procedure TCloudBase.LoadTokens;
var
  Settings: TIniFile;
  RegInifile: TReginifile;
  s:string;
begin
  if (PersistTokens.Key = '') or (PersistTokens.Section = '') then
    Exit;

  case PersistTokens.Location of
  plIniFile:
    begin
      Settings := TIniFile.Create(PersistTokens.Key);

      s := Settings.ReadString(PersistTokens.Section,'ACCESS_TOKEN','');
      FToken_Access := string(Decrypt(AnsiString(s),1969));
      s := Settings.ReadString(PersistTokens.Section,'AUTH_TOKEN','');
      FToken_Auth := string(Decrypt(AnsiString(s),1969));
      s := Settings.ReadString(PersistTokens.Section,'ACCESS_TOKEN_SECRET','');
      FToken_Access_Secret := string(Decrypt(AnsiString(s),1969));
      s := Settings.ReadString(PersistTokens.Section,'AUTH_TOKEN_SECRET','');
      FToken_Auth_Secret := string(Decrypt(AnsiString(s),1969));
      s := Settings.ReadString(PersistTokens.Section,'REFRESH_TOKEN','');
      FToken_Refresh := string(Decrypt(AnsiString(s),1969));

      Settings.Free;
    end;
  plRegistry:
    begin
      RegIniFile := TRegIniFile.Create(PersistTokens.Key);

      s := RegIniFile.ReadString(PersistTokens.Section,'ACCESS_TOKEN','');
      FToken_Access := string(Decrypt(AnsiString(s),1969));
      s := RegIniFile.ReadString(PersistTokens.Section,'AUTH_TOKEN','');
      FToken_Auth := string(Decrypt(AnsiString(s),1969));
      s := RegIniFile.ReadString(PersistTokens.Section,'ACCESS_TOKEN_SECRET','');
      FToken_Access_Secret := string(Decrypt(AnsiString(s),1969));
      s := RegIniFile.ReadString(PersistTokens.Section,'AUTH_TOKEN_SECRET','');
      FToken_Auth_Secret := string(Decrypt(AnsiString(s),1969));
      s := RegIniFile.ReadString(PersistTokens.Section,'REFRESH_TOKEN','');
      FToken_Refresh := string(Decrypt(AnsiString(s),1969));

      RegIniFile.Free;
    end;
  end;

end;

procedure TCloudBase.Log(Msg: string);
var
  tf:text;
  fn: string;
begin
  if not FLogging then
    Exit;
  if FLogFileName = '' then
    Exit;

  if (pos('\',FLogFilename) = 0) and (pos('/',FLogfilename) = 0) and (pos(':',FLogfilename) = 0) then
    fn := AddBackslash(UserDocDir) + FLogfilename
  else
    fn := FLogfilename;

  AssignFile(tf,fn);
  {$i-}
  Append(tf);
  {$i+}
  if IOResult <> 0 then
  begin
    {$i-}
    Rewrite(tf);
    {$i+}
    if IOResult <> 0 then
      Exit;
  end;

  Msg := DateTimeToISO(Now) + ':' + Msg;

  Writeln(tf,Msg);
  CloseFile(tf);
end;

{ TAuthForm }

procedure TAuthFormSettings.Assign(Source: TPersistent);
begin
  if (Source is TAuthFormSettings) then
  begin
    FWidth := (Source as TAuthFormSettings).Width;
    FHeight := (Source as TAuthFormSettings).Height;
    FCaption := (Source as TAuthFormSettings).Caption;
  end;
end;

constructor TAuthFormSettings.Create;
begin
  inherited;
  FWidth := 900;
  FHeight := 600;
  FCaption := 'Authorize';
end;

{ TCloudStorage }

constructor TCloudStorage.Create(AOwner: TComponent);
begin
  inherited;
  FDrive := CreateCloudItems;
end;

function TCloudStorage.CreateCloudItems: TCloudItems;
begin
  Result := TCloudItems.Create;
end;

function TCloudStorage.CreateFolder(ci: TCloudItem; const FolderName: string): TCloudItem;
begin
  Result := nil;
end;

function TCloudStorage.Delete(ci: TCloudItem): boolean;
begin
  Result := false;
  if not Assigned(ci) then
    Exit;
end;

function TCloudStorage.Delete(const FileName: string): boolean;
begin
  Result := true;
end;

destructor TCloudStorage.Destroy;
begin
  FDrive.Free;
  inherited;
end;

function TCloudStorage.Download(const FileName, TargetFile: string): boolean;
begin
  Result := true;
end;

function TCloudStorage.Download(ci: TCloudItem; const TargetFile: string): boolean;
begin
  Result := false;
  if not Assigned(ci) or (ci.ItemType = ciFolder) then
    Exit;
end;

procedure TCloudStorage.FillTreeView(ATreeView: TTreeView);

  procedure AddFolder(ParentNode: TTreeNode; Drive: TCloudItems);
  var
    tn: TTreeNode;
    i: integer;
  begin
    for i := 0 to Drive.Count - 1 do
    begin
      tn := ATreeview.Items.AddChild(ParentNode, Drive.Items[i].FileName);
      if Assigned(ATreeView.Images) then
      begin
        if Drive.Items[i].ItemType = ciFolder then
        begin
          tn.ImageIndex := 0;
          tn.ExpandedImageIndex := 2;
        end
        else
        begin
          tn.ImageIndex := 1;
          tn.SelectedIndex := 1;
        end;
      end;

      tn.Data := Drive.Items[i];
      if (Drive.Items[i].ItemType = ciFolder) and Assigned(Drive.Items[i].Folder) then
      begin
        AddFolder(tn, Drive.Items[i].Folder);
      end;
    end;
  end;

begin
  if Assigned(ATreeView) then
  begin
    ATreeView.Items.Clear;
    AddFolder(nil, Drive);
    if ATreeView.Items.Count > 0 then
      ATreeView.Select(ATreeView.Items[0]);
  end;
end;

procedure TCloudStorage.GetDriveInfo;
begin
  //
  Drive.Clear;



end;

{------------------------------------------------------------------------------}

{ TCloudFiles }

function TCloudItems.Add: TCloudItem;
begin
  Result := TCloudItem(inherited Add);
end;

constructor TCloudItems.Create;
begin
  inherited Create(GetItemClass);
end;

function TCloudItems.GetItemClass: TCollectionItemClass;
begin
  Result := TCloudItem;
end;

function TCloudItems.GetItems(index: integer): TCloudItem;
begin
  Result := TCloudItem(inherited Items[index]);
end;

function TCloudItems.Insert(Index: integer): TCloudItem;
begin
  Result := TCloudItem(inherited Insert(index));
end;

procedure TCloudItems.SetItems(index: integer; const Value: TCloudItem);
begin
  inherited Items[index] := Value;
end;

{------------------------------------------------------------------------------}

{ TCloudItem }

procedure TCloudItem.Assign(Source: TPersistent);
begin
  if (Source is TCloudItem) then
  begin
    FFileName := (Source as TCloudItem).FileName;
    FSize := (Source as TCloudItem).Size;
    FModifiedDate := (Source as TCloudItem).ModifiedDate;
    FCreationDate := (Source as TCloudItem).CreationDate;
    FItemType := (Source as TCloudItem).ItemType;
    FTag := (Source as TCloudItem).Tag;
  end;
end;

procedure TCloudItem.CheckFolder;
begin
  if not Assigned(FFolder) then
    FFolder := (Collection as TCloudItems).ClassType.Create as TCloudItems;
end;

constructor TCloudItem.Create(Collection: TCollection);
begin
  inherited;
  FFolder := nil;
end;

destructor TCloudItem.Destroy;
begin
  if Assigned(FFolder) then
    FreeAndNil(FFolder);
  inherited;
end;

{------------------------------------------------------------------------------}

{ TPersistTokens }

procedure TPersistTokens.Assign(Source: TPersistent);
begin
  if (Source is TPersistTokens) then
  begin
    FLocation := (Source as TPersistTokens).Location;
    FSection := (Source as TPersistTokens).Section;
    FKey := (Source as TPersistTokens).Key;
  end;
end;

{------------------------------------------------------------------------------}

{ TCloudApp }

procedure TCloudApp.Assign(Source: TPersistent);
begin
  if (Source is TCloudApp) then
  begin
    FKey := (Source as TCloudApp).Key;
    FSecret := (Source as TCloudApp).Secret;
    FName := (Source as TCloudApp).Name;
  end;
end;


{ TCloudLookupProvider }

procedure TCloudLookupProvider.Lookup(AText: string; Values: TStrings);
begin
  //
end;


{$IFDEF FREEWARE}
{$I TRIAL.INC}
{$ENDIF}


end.
