{***************************************************************************}
{ TMS Google 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.                                      }
{***************************************************************************}
unit CloudGoogle;

interface

uses
  Classes, CloudBase, SHDocVw, SysUtils, ComCtrls,
  IdCustomTCPServer, IdCustomHTTPServer, IdContext, IdHTTPServer;


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

  // Version history
  // v1.0.0.0 : First release
  // v1.0.1.0 : New : Uses Locale property for consent page language customization

type
  TCloudGoogle = class(TCloudBase)
  private
    FCallBackURL: string;
    FHttpServer: TIdHTTPServer;
  protected
    function GetVersionNr: integer; override;
    procedure DoCommandGet(AContext: TIdContext;
      ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
    function GetLocaleParam: string;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function TestTokens: boolean; override;
    function RefreshAccess: boolean; override;
    procedure DoAuth; override;
    property CallBackURL: string read FCallBackURL write FCallBackURL;

  published
    property Scopes;
    property Locale;
  end;


implementation


uses
  DBXJSON, Windows;


{ TCloudGoogle }

constructor TCloudGoogle.Create(AOwner: TComponent);
begin
  inherited;
  FHttpServer := nil;
  FCallBackURL := 'http://127.0.0.1:8888/';
  Scopes.Clear;
end;

destructor TCloudGoogle.Destroy;
begin
  inherited;
end;

procedure TCloudGoogle.DoAuth;
var
  url: string;
begin
  inherited;
     (*
  url :=
   '?scope=' + URLEncode('https://www.googleapis.com/auth/userinfo.email')
    + '+' + URLEncode('https://www.googleapis.com/auth/userinfo.profile')
    + '+' + URLEncode('https://www.googleapis.com/auth/plus.me')
//    + '+' + URLEncode('https://www.googleapis.com/auth/calendar')
    + '+' + URLEncode('https://www.googleapis.com/auth/drive')
    + '+' + URLEncode('https://www.googleapis.com/auth/drive.file')
    *)

  url :=
      '?scope=' + ScopeParamText('+',true)
    + '&state=profile'
    + '&redirect_uri='+URLEncode(CallBackURL)
    + '&response_type=code'
    + '&client_id=' + App.Key
    + '&approval_prompt=force'
    + '&access_type=offline'
    + GetLocaleParam;
//    + '&hl=fr';

  url := 'https://accounts.google.com/o/oauth2/auth' + url;

  if not Assigned(FHttpServer) then
    FHttpServer := TIdHTTPServer.Create(Owner);

  FHttpServer.Active := false;
  FHttpServer.DefaultPort := 8888;
  FHttpServer.OnCommandGet := DoCommandGet;
  FHttpServer.Active := true;

  if Assigned(AuthBrowser) then
    AuthBrowser.Navigate(url)
  else
    CreateOAuthForm(url,nil,nil);
end;

procedure TCloudGoogle.DoCommandGet(AContext: TIdContext;
  ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
var
  fserver,faction: string;
  fdata,lf:string;
  resdat: ansistring;
  o: TJSONObject;
  jv: TJSONValue;
  headers: TCoreCloudHeaders;
begin
  // detect Google callback for profile state
  if (arequestinfo.params.Count = 2) and (arequestinfo.params.IndexOfName('state') <> -1) then
  begin
    Token_Auth := arequestinfo.params.ValueFromIndex[arequestinfo.params.IndexOfName('code')];

    // as soon as the auth. code is received -> request access token
    FServer := 'accounts.google.com';
    FAction := '/o/oauth2/token';
    AddHeader(headers, 'Content-Type', 'application/x-www-form-urlencoded');

    lf := '&';

    FData :=
      'code=' + UrlEncode(Token_Auth) + lf
    + 'client_id=' + UrlEncode(App.Key) + lf
    + 'client_secret=' + UrlEncode(App.Secret) + lf
    + 'redirect_uri=' + UrlENcode(CallBackURL)+lf
    + 'grant_type=authorization_code';

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

//    OutputDebugString(pchar('ACCESS TOKEN= ' + string(resdat)));

    resdat := CleanUpJSON(resdat);

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

    if Assigned(jv) then
    begin
      try
        o := jv as TJSONObject;
        Token_Access := GetJSONProp(o,'access_token');
        Token_Refresh := GetJSONProp(o,'refresh_token');
      finally
        jv.Free;
      end;
      DoReceivedAccessToken;
      CloseOAuthForm;
    end;
  end;
end;

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

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

function TCloudGoogle.RefreshAccess: boolean;
var
  resdat: ansistring;
  FServer,FAction: string;
  headers: TCoreCloudHeaders;
  FData: string;
  lf,at: string;
  jv: TJSONValue;
  jo: TJSONObject;
begin
  Result := false;

  if Token_Refresh = '' then
    Exit;

  FServer := 'accounts.google.com';
  FAction := '/o/oauth2/token';
  AddHeader(headers, 'Content-Type', 'application/x-www-form-urlencoded');

  lf := '&';

  FData :=
      'client_id=' + UrlEncode(App.Key) + lf
    + 'client_secret=' + UrlEncode(App.Secret) + lf
    + 'refresh_token=' + URLEncode(Token_Refresh) + lf
    + 'grant_type=refresh_token';

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

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

        at := GetJSONProp(jo,'access_token');

        Result := at <> '';
        if Result then
          Token_Access := at;
      finally
        jv.Free;
      end;
    end;
  end;
end;

function TCloudGoogle.TestTokens: boolean;
var
  url: string;
  o: TJSONObject;
begin
  Result := false;

//  url := 'https://www.googleapis.com/drive/v2/about/?access_token=' + Token_Access;
  url := 'https://www.googleapis.com/calendar/v3/users/me/settings?access_token=' + Token_Access;

  o := GetJSONObject(url);
  if Assigned(o) then
  begin
    try
//      OutputDebugString(pchar(o.ToString));
      Result := GetJSONProp(o,'kind') <> '';
    finally
      o.Free;
    end;
  end;
end;

end.
