{***************************************************************************}
{ TMS WinLive Cloud access                                                  }
{ 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.                                      }
{***************************************************************************}

{$I TMSDEFS.INC}

unit CloudWinLive;

interface

uses
  Classes, Windows, Messages, SHDocVw, CloudBase, SysUtils, ComCtrls;


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

  // v1.0.0.0 : First release
  // v1.0.0.1 : Fixed : Issue with create folder
  // v1.0.1.0 : New : Uses Locale property for consent page language customization

type
  TSkyDriveItems = class;

  TSkyDriveItemAccess = (iaPublic, iaPrivate);

  TSkyDriveUser = record
    Name: string;
    ID: string;
  end;

  TSkyDriveItem = class(TCloudItem)
  private
    FID: string;
    FAccess: TSkyDriveItemAccess;
    FDescription: string;
    FLink: string;
    FUser: TSkyDriveUser;
    FCommentsEnabled: boolean;
    FAccessValue: string;
  protected
    property AccessValue: string read FAccessValue write FAccessValue;
  public
    procedure Assign(Source: TPersistent); override;
  published
    property ID: string read FID write FID;
    property Access: TSkyDriveItemAccess read FAccess write FAccess;
    property Description: string read FDescription write FDescription;
    property Link: string read FLink write FLink;
    property User: TSkyDriveUser read FUser write FUser;
    property CommentsEnabled: boolean read FCommentsEnabled write FCommentsEnabled;
  end;

  TSkyDriveItems = class(TCloudItems)
  private
    function GetItems(index: integer): TSKyDriveItem;
    procedure SetItems(index: integer; const Value: TSKyDriveItem);
  protected
    function GetItemClass: TCollectionItemClass; override;
  public
    constructor Create;
    function Add: TSkyDriveItem;
    function Insert(Index: integer): TSkyDriveItem;
    property Items[index: integer]: TSKyDriveItem read GetItems write SetItems;
  end;

  TAdvSkyDrive = class(TCloudStorage)
  private
    FFolderID: string;
    function GetAuthURL: string;
    function SignURL(url: string): string;
  protected
    function CreateCloudItems: TCloudItems; override;
    function GetVersionNr: integer; override;
    {$IF CompilerVersion >= 23.0}
    procedure BeforeNavigate2(ASender: TObject; const pDisp: IDispatch; const URL, Flags, TargetFrameName, PostData,
      Headers: OleVariant; var Cancel: WordBool);
    procedure NavigateComplete2(ASender: TObject; const pDisp: IDispatch; const URL: OleVariant);
    {$ELSE}
    procedure BeforeNavigate2(ASender: TObject; const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData,
      Headers: OleVariant; var Cancel: WordBool);
    procedure NavigateComplete2(ASender: TObject; const pDisp: IDispatch; var URL: OleVariant);
    {$IFEND}
    function GetSkyDrive: TSkyDriveItems;
    function GetLocaleParam: string;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function TestTokens: boolean; override;
    function RefreshAccess: boolean; override;
    procedure DoAuth; override;
    procedure GetDriveInfo; override;
    procedure GetSkyDriveFolder(folderid: string; Items: TSkyDriveItems);
    function CreateFolder(ci: TCloudItem; const FolderName: string): TCloudItem; override;
    property SkyDrive: TSkyDriveItems read GetSkyDrive;
    property FolderID: string read FFolderID;
    function Download(ci: TCloudItem; const TargetFile: string): boolean; override;
    function Delete(ci: TCloudItem): boolean; override;
    function Upload(Folder: TSkyDriveItem; FileName: string): TSkyDriveItem;
  published
    property Scopes;
    property Locale;
  end;

implementation

uses
  DBXJSON;

{ TSkyDriveItems }

function TSkyDriveItems.Add: TSkyDriveItem;
begin
  Result := TSkyDriveItem(inherited Add);
end;

constructor TSkyDriveItems.Create;
begin
  inherited Create;
end;

function TSkyDriveItems.GetItemClass: TCollectionItemClass;
begin
  Result := TSkyDriveItem;
end;

function TSkyDriveItems.GetItems(index: integer): TSKyDriveItem;
begin
  Result := TSkyDriveItem(inherited Items[Index]);
end;

function TSkyDriveItems.Insert(Index: integer): TSkyDriveItem;
begin
  Result := TSkyDriveItem(inherited Insert(Index));
end;

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

{ TAdvSkyDrive }

{$IF CompilerVersion >= 23.0}
procedure TAdvSkyDrive.BeforeNavigate2(ASender: TObject; const pDisp: IDispatch;
  const URL, Flags, TargetFrameName, PostData, Headers: OleVariant;
  var Cancel: WordBool);
{$ELSE}
procedure TAdvSkyDrive.BeforeNavigate2(ASender: TObject; const pDisp: IDispatch;
  var URL, Flags, TargetFrameName, PostData, Headers: OleVariant;
  var Cancel: WordBool);
{$IFEND}
var
  authid: string;
  accesstokenid: string;
  s: string;
  atpos: integer;
begin
  // get access token from here : implicit code grant flow
  s := url;
  authid := 'authentication_token=';
  accesstokenid := 'access_token=';

  atpos := pos(authid, url);

  if atpos > 0 then
  begin
    s := copy(url,atpos + length(authid), length(url));
    atpos := pos('&',s);

    if atpos > 0 then
      s := copy(s,1,atpos-1);

    Token_Auth := s;

    atpos := pos(accesstokenid,url);
    if atpos > 0 then
    begin
      s := copy(url,atpos + length(accesstokenid), length(url));
      atpos := pos('&',s);
      s := copy(s,1,atpos-1);
      Token_Access := s;
    end;

    // raise event that access was succesfully gained
    DoReceivedAccessToken;
    CloseOAuthForm;
  end;
end;

constructor TAdvSkyDrive.Create(AOwner: TComponent);
begin
  inherited;
  APIBase := 'https://apis.live.net/v5.0/';

  // scopes required for full read-write to SkyDrive
  Scopes.Add('wl.signin');
  Scopes.Add('wl.basic');
  Scopes.Add('wl.offline_access');
  Scopes.Add('wl.skydrive');
  Scopes.Add('wl.skydrive_update');
end;

function TAdvSkyDrive.CreateCloudItems: TCloudItems;
begin
  Result := TSkyDriveItems.Create;
end;

function TAdvSkyDrive.CreateFolder(ci: TCloudItem; const FolderName: string): TCloudItem;
var
  headers: TCoreCloudHeaders;
  data,resdat: ansistring;
  url: string;
  Folder: TSkyDriveItem;
begin
  Result := nil;

  if not (ci is TSkyDriveItem) then
    Exit;

  if Assigned(ci) then
  begin
    Folder := ci as TSkyDriveItem;
    if not (Folder.ItemType = ciFolder) then
      Exit;
  end
  else
    Folder := nil;

  AddHeader(headers, 'Authorization', 'Bearer ' + Token_Access  + #13#10);
  AddHeader(headers, 'Content-Type', 'application/json');

  data :=
      '{' + #13#10
    +  'name: "' + ansistring(FolderName) + '"' + #13#10
    + '}';

  if Assigned(Folder) then
    url := APIBase + Folder.ID
  else
    url := APIBase + 'me/skydrive';

  HttpsPost(ExtractServer(url),RemoveServer(url),headers,data,resdat);

  if Assigned(Folder) then
    Result := Folder.Folder.Add
  else
    Result := SkyDrive.Add;
  Result.FileName := FolderName;
  Result.ItemType := ciFolder;
end;

function TAdvSkyDrive.Delete(ci: TCloudItem): boolean;
var
  url: string;
  resdat,data: ansistring;
  res: integer;
  item: TSkyDriveItem;

begin
  Result := false;

  inherited;

  // DELETE https://apis.live.net/v5.0/file.b7c3b8f9g3616f6f.B7CB8F9G3626F6!225?access_token=ACCESS_TOKEN

  if not (ci is TSkyDriveItem) then
    Exit;

  Item := ci as TSkyDriveItem;

  url := SignURL(APIBase + Item.ID+'?');
  data := '';
  res := HttpsDelete(ExtractServer(url),RemoveServer(url),nil,data,resdat);

  if (res = 204) then
  begin
    Result := true;
  end;
end;

destructor TAdvSkyDrive.Destroy;
begin
  inherited;
end;

procedure TAdvSkyDrive.DoAuth;
var
  url: string;
begin
  inherited;

  url := GetAuthURL;

  if Assigned(AuthBrowser) then
  begin
    AuthBrowser.OnBeforeNavigate2 := BeforeNavigate2;
    AuthBrowser.OnNavigateComplete2 := NavigateComplete2;
    AuthBrowser.Navigate(url);
  end
  else
  begin
    CreateOAuthForm(url,BeforeNavigate2,NavigateComplete2);
  end;
end;

function TAdvSkyDrive.Download(ci: TCloudItem; const TargetFile: string): boolean;
var
  url: string;
  o: TJSONObject;
  Item: TSkyDriveItem;
begin
  Result := false;

  inherited;

  if not (ci is TSkyDriveItem) then
    Exit;

  Item := (ci as TSkyDriveItem);

  // get download URL based on ID
  url := SignURL(APIBase + Item.ID + '/content?suppress_redirects=true&');

  o := GetJSONObject(url);

  if Assigned(o) then
  begin
    try
      url := GetJSONProp(o,'location');
      HttpsGet(Url, TargetFile, Item.Size);
      Result := true;
    finally
      o.Free;
    end;
  end;
   //url := 'https://apis.live.net/v5.0/'+fileid+'/content?suppress_redirects=true&access_token='+accesstoken;
end;

function TAdvSkyDrive.GetAuthURL: string;
begin
  // locales:
  //http://msdn.microsoft.com/en-us/library/live/hh243645.aspx

  // Implicit grant flow, only access token
  Result := 'https://oauth.live.com/authorize?client_id='+App.Key + '&response_type=token&scope=' + URLEncode(ScopeParamText(',')) + '&redirect_uri=https%3a%2f%2foauth.live.com%2fdesktop&display=touch';
  // Authorization code grant flow, needed to get a refresh token
  Result := 'https://oauth.live.com/authorize?client_id='+App.Key + '&response_type=code' + GetLocaleParam + '&scope=' + URLEncode(ScopeParamText(',')) + '&redirect_uri='+URLEncode('https://oauth.live.com/desktop')+'&display=touch';
end;

procedure TAdvSkyDrive.GetDriveInfo;
var
  o: TJSONObject;
begin
  SkyDrive.Clear;
  o := GetJSONObject(SignURL(APIBase + 'me/skydrive?'));

  if Assigned(o) then
  begin
    try
      FFolderID := GetJSONProp(o,'id');
      GetSkyDriveFolder(FFolderID, SkyDrive);
    finally
      o.Free;
    end;
  end;
end;

function TAdvSkyDrive.GetLocaleParam: string;
begin
  case Locale of
    lcDefault: Result := '';
    lcEnglish: Result := '&locale=en';
    lcDutch: Result := '&locale=nl';
    lcGerman: Result := '&locale=de';
    lcFrench: Result := '&locale=fr';
    lcSpanish: Result := '&locale=es';
    lcItalian: Result := '&locale=it';
    lcPortuguese: Result := '&locale=pt-pt';
    lcGreek: Result := '&locale=el';
    lcDanish: Result := '&locale=da';
    lcRussian: Result := '&locale=ru';
    lcRomanian: Result := '&locale=ro';
    lcSwedish: Result := '&locale=sv';
    lcFinnish: Result := '&locale=fi';
    lcTurkish: Result := '&locale=tr';
    lcJapanese: Result := '&locale=ja';
  end;
end;

function TAdvSkyDrive.GetSkyDrive: TSkyDriveItems;
begin
  Result := Drive as TSkyDriveItems;
end;

procedure TAdvSkyDrive.GetSkyDriveFolder(folderid: string;
  Items: TSkyDriveItems);
var
  o,fo,usero,shareo: TJSONObject;
  ja: TJSONArray;
  i: integer;
  sdi: TSkyDriveItem;
  subitems: TSkyDriveItems;
  user: TSkyDriveUser;
  sz: string;
  obj: TJSONValue;
  fd: string;
  ftype: string;
begin
  o := GetJSONObject(SignURL(APIBase + folderid+'/files?'));

  if Assigned(o) then
  begin
    try
      //
      ja := GetJSONValue(o,'data') as TJSONArray;

      for i := 0 to ja.Size - 1 do
      begin
        fo := ja.Get(i) as TJSONObject;

        sdi := Items.Add as TSkyDriveItem;

        sdi.FileName := GetJSONProp(fo,'name');


        sdi.ID := GetJSONProp(fo,'id');
        sdi.Description := GetJSONProp(fo,'description');

        sz := GetJSONProp(fo,'size');

        sdi.Size := StrToInt64T(sz);

        sdi.Link := GetJSONProp(fo,'link');

        obj := GetJSONValue(fo,'from');
        if Assigned(obj) then
        begin
          usero := GetJSONValue(fo,'from') as TJSONObject;
          User.ID := GetJSONProp(usero,'id');
          User.Name := GetJSONProp(usero,'name');
          sdi.User := user;
        end;

        obj := GetJSONValue(fo,'shared_with');
        if Assigned(obj) then
        begin
          shareo :=  obj as TJSONObject;
          sdi.AccessValue := GetJSONProp(shareo,'access');
        end;

        fd := GetJSONProp(fo,'created_time');

        if fd <> '' then
          sdi.CreationDate := IsoToDateTime(fd);

        fd := GetJSONProp(fo,'updated_time');
        if fd <> '' then
          sdi.ModifiedDate := IsoToDateTime(fd);

        //
        ftype := GetJSONProp(fo,'type');

        if (ftype = 'folder') or (ftype = 'album') then
        begin
          sdi.ItemType := ciFolder;
        end
        else
        begin
          sdi.ItemType := ciFile;
        end;

        if sdi.ItemType = ciFolder then
        begin
          subitems := TSkyDriveItems.Create;
          sdi.Folder := subitems;
          GetSkyDriveFolder(sdi.ID, sdi.Folder as TSkyDriveItems);
        end;
      end;
    finally
      o.Free;
    end;
  end;
end;

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

{$IF CompilerVersion >= 23.0}
procedure TAdvSkyDrive.NavigateComplete2(ASender: TObject;
  const pDisp: IDispatch; const URL: OleVariant);
{$ELSE}
procedure TAdvSkyDrive.NavigateComplete2(ASender: TObject;
  const pDisp: IDispatch; var URL: OleVariant);
{$IFEND}
var
  s:string;
  sig:string;
  sigp: integer;
  fserver,faction: string;
  headers: TCoreCloudHeaders;
  fdata,lf:string;
  resdat: ansistring;
  jv: TJSONValue;
  jo: TJSONObject;
  acc: boolean;
begin
  s := URL;
  sig := 'desktop?code=';
  sigp := pos(sig,s);
  if sigp > 0 then
  begin
    Token_Auth := copy(s,sigp + length(sig),length(s));

    FServer := 'login.live.com';
    FAction := '/oauth20_token.srf';
    addheader(headers, 'Content-Type', 'application/x-www-form-urlencoded');

    lf := '&';

    FData :=
      'client_id=' + UrlEncode(App.Key) + lf
    + 'client_secret=' + UrlEncode(App.Secret) + lf
    + 'code=' + UrlEncode(Token_Auth) + lf
    + 'redirect_uri=' + UrlENcode('https://oauth.live.com/desktop')+lf
    + 'grant_type=authorization_code';

    HttpsPost(FServer, FAction, headers, AnsiString(FData), resdat);

    if (resdat <> '') then
    begin
      jv := TJSONObject.ParseJSONValue(string(resdat));
      if Assigned(jv) then
      begin
        jo := jv as TJSONObject;
        acc := false;

        try
          s := GetJSONProp(jo,'access_token');
          if (s <> '') then
          begin
            acc := true;
            Token_Access := s;
            Token_Refresh := GetJSONProp(jo,'refresh_token');
          end;
        finally
          jo.Free;
        end;


        if acc then
          DoReceivedAccessToken;

        CloseOAuthForm;
      end;
    end;
  end;
end;

function TAdvSkyDrive.RefreshAccess: boolean;
var
  s: string;
  fserver,faction: string;
  fdata,lf: string;
  resdat: ansistring;
  jv: TJSONValue;
  jo: TJSONObject;
  acc: boolean;
  headers: TCoreCloudHeaders;
begin
  Result := false;

  if Token_Refresh = '' then
    Exit;

  FServer := 'login.live.com';
  FAction := '/oauth20_token.srf';
  AddHeader(headers, 'Content-Type', 'application/x-www-form-urlencoded');

  lf := '&';

  FData :=
    'client_id=' + URLEncode(App.Key) + lf
  + 'client_secret=' + URLEncode(App.Secret) + lf
  + 'code=' + URLEncode(Token_Auth) + lf
  + 'redirect_uri=' + URLENcode('https://oauth.live.com/desktop')+lf
  + 'grant_type=refresh_token'+lf
  + 'refresh_token=' + URLEncode(Token_Refresh);

  HttpsPost(FServer, FAction, headers, AnsiString(FData), resdat);

  if (resdat <> '') then
  begin
    jv := TJSONObject.ParseJSONValue(string(resdat));
    if Assigned(jv) then
    begin
      jo := jv as TJSONObject;
      acc := false;

      try
        s := GetJSONProp(jo,'access_token');
        if (s <> '') then
        begin
          acc := true;
          Token_Access := s;
        end;
      finally
        jo.Free;
      end;

      if acc then
        Result := true;
    end;
  end;
end;

function TAdvSkyDrive.SignURL(url: string): string;
begin
  Result := url + 'access_token=' + Token_Access;
end;

function TAdvSkyDrive.TestTokens: boolean;
var
  url: string;
  o: TJSONObject;
begin
  Result := false;
  url := SignURL(APIBase + 'me?');
  o := GetJSONObject(url);

  if Assigned(o) then
  begin
    try
      Result := (GetJSONProp(o,'id') <> '') and (GetJSONProp(o,'name') <> '');
    finally
      o.Free;
    end;
  end;
end;

function TAdvSkyDrive.Upload(Folder: TSkyDriveItem; FileName: string): TSkyDriveItem;
var
  url,fn,sz: string;
  resdat: ansistring;
  folderid,fileid: string;
  jv,obj,erro: TJSONValue;
  jo,usero: TJSONObject;
  fd,err: string;
  user: TSkyDriveUser;
begin
  Result := nil;
  fn := ExtractFileName(FileName);
  folderid := 'me/skydrive';

  if Assigned(Folder) and (Folder.ItemType = ciFolder) then
    folderid := Folder.ID;

  url := SignURL(APIBase + folderid + '/files/' + fn + '?');
  resdat := HttpsPut(url, ExtractFilePath(FileName), fn, nil, '', hcPutNoHeader);

  resdat := CleanUpJSON(resdat);

  if resdat <> '' then
  begin
    jv := TJSONObject.ParseJSONValue(string(resdat));

    if Assigned(jv) then
    begin
      jo := jv as TJSONObject;

      erro := GetJSONValue(jo,'error');
      if Assigned(erro) then
      begin
        err := GetJSONProp(erro as TJSONObject,'message');
        raise Exception.Create('Error uploading file: ' + err);
      end
      else
      begin
        fileid := GetJSONProp(string(resdat),'id');

        // get file info with ID here....

        resdat := HttpsGet(SignURL(APIBase + fileid + '?'));

        jv := TJSONObject.ParseJSONValue(string(resdat));

        if Assigned(jv) then
        begin
          jo := jv as TJSONObject;

          if Assigned(Folder) then
          begin
            if Folder.ItemType = ciFolder then
            begin
               Result := Folder.Folder.Add as TSkyDriveItem;
            end;
          end
          else
            Result := SkyDrive.Add;

          Result.FileName := ExtractFileName(FileName);
          Result.ItemType := ciFile;
          Result.ID := fileid;

          sz := GetJSONProp(jo,'size');

          Result.Size := StrToInt64T(sz);

          fd := GetJSONProp(jo,'created_time');
          if fd <> '' then
            Result.CreationDate := IsoToDateTime(fd);
          fd := GetJSONProp(jo,'updated_time');
          if fd <> '' then
            Result.ModifiedDate := IsoToDateTime(fd);

          Result.Description := GetJSONProp(jo,'description');

          Result.Link := GetJSONProp(jo,'link');

          obj := GetJSONValue(jo,'from');
          if Assigned(obj) then
          begin
            usero := obj as TJSONObject;
            user.ID := GetJSONProp(usero,'id');
            user.Name := GetJSONProp(usero,'name');
            Result.User := user;
          end;
        end;
      end;
    end;
  end;
end;

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

{ TSkyDriveItem }

procedure TSkyDriveItem.Assign(Source: TPersistent);
begin
  inherited;
  if (Source is TSkyDriveItem) then
  begin
    FID := (Source as TSkyDriveItem).ID;
    FAccess := (Source as TSkyDriveItem).Access;
    FDescription := (Source as TSkyDriveItem).Description;
    FLink := (Source as TSkyDriveItem).Link;
    FUser := (Source as TSkyDriveItem).User;
    FCommentsEnabled := (Source as TSkyDriveItem).CommentsEnabled;
  end;
end;

end.
