unit CloudLive;

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.1.0 : New : Locale property exposed for TAdvLiveCalendar & TAdvLiveContacts

type

  TCloudLive = class(TCloudBase)
  private
    FAPIBase: string;
    function GetAuthURL: string;
    function SignURL(url: string): string;
  protected
    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 GetLocaleParam: string;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function TestTokens: boolean; override;
    function RefreshAccess: boolean; override;
    procedure DoAuth; override;
  end;


implementation

uses
  DBXJSON;

{ TCloudLive }


{$IF CompilerVersion >= 23.0}
procedure TCloudLive.BeforeNavigate2(ASender: TObject; const pDisp: IDispatch;
  const URL, Flags, TargetFrameName, PostData, Headers: OleVariant;
  var Cancel: WordBool);
{$ELSE}
procedure TCloudLive.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 TCloudLive.Create(AOwner: TComponent);
begin
  inherited;
  FAPIBase := 'https://apis.live.net/v5.0/';
end;

destructor TCloudLive.Destroy;
begin

  inherited;
end;

procedure TCloudLive.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 TCloudLive.GetAuthURL: string;
begin
  // 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;

function TCloudLive.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 TCloudLive.GetVersionNr: integer;
begin
  Result := MakeLong(MakeWord(BLD_VER,REL_VER),MakeWord(MIN_VER,MAJ_VER));
end;

{$IF CompilerVersion >= 23.0}
procedure TCloudLive.NavigateComplete2(ASender: TObject; const pDisp: IDispatch;
  const URL: OleVariant);
{$ELSE}
procedure TCloudLive.NavigateComplete2(ASender: TObject; const pDisp: IDispatch;
  var URL: OleVariant);
{$IFEND}
var
  s:string;
  sig:string;
  sigp: integer;
  headers: TCoreCloudHeaders;
  fserver,faction: string;
  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 TCloudLive.RefreshAccess: boolean;
var
  s: string;
  headers: TCoreCloudHeaders;
  fserver,faction: string;
  fdata,lf: string;
  resdat: ansistring;
  jv: TJSONValue;
  jo: TJSONObject;
  acc: boolean;
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 TCloudLive.SignURL(url: string): string;
begin
  Result := url + 'access_token=' + Token_Access;
end;

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

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

end.
