paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-16 23:49:07 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Added google GMail demo

Browse Source 
git-svn-id: trunk@49041 -
This commit is contained in:
michael 2015-05-16 08:01:27 +00:00
parent 6d6f3e887c
commit d370f4fd97
8 changed files with 712 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
.gitattributes vendored
View File

@ -1670,6 +1670,13 @@ components/googleapis/demo/drive/frmmain.pp svneol=native#text/plain
components/googleapis/demo/drive/frmselectdownload.lfm svneol=native#text/plain components/googleapis/demo/drive/frmselectdownload.lfm svneol=native#text/plain
components/googleapis/demo/drive/frmselectdownload.pp svneol=native#text/plain components/googleapis/demo/drive/frmselectdownload.pp svneol=native#text/plain
components/googleapis/demo/drive/google.ini svneol=native#text/plain components/googleapis/demo/drive/google.ini svneol=native#text/plain
components/googleapis/demo/gmail/frmmain.lfm svneol=native#text/plain
components/googleapis/demo/gmail/frmmain.pp svneol=native#text/plain
components/googleapis/demo/gmail/gmaildemo.ico -text
components/googleapis/demo/gmail/gmaildemo.lpi svneol=native#text/plain
components/googleapis/demo/gmail/gmaildemo.lpr svneol=native#text/plain
components/googleapis/demo/gmail/gmaildemo.res -text
components/googleapis/demo/gmail/google.ini svneol=native#text/plain
components/googleapis/demo/tasks/frmmain.lfm svneol=native#text/plain components/googleapis/demo/tasks/frmmain.lfm svneol=native#text/plain
components/googleapis/demo/tasks/frmmain.pp svneol=native#text/plain components/googleapis/demo/tasks/frmmain.pp svneol=native#text/plain
components/googleapis/demo/tasks/google.ini svneol=native#text/plain components/googleapis/demo/tasks/google.ini svneol=native#text/plain

148
components/googleapis/demo/gmail/frmmain.lfm Normal file
View File

@ -0,0 +1,148 @@
object MainForm: TMainForm
Left = 506
Height = 636
Top = 173
Width = 1025
Caption = 'Google mail demo'
ClientHeight = 636
ClientWidth = 1025
OnCreate = FormCreate
OnDestroy = FormDestroy
LCLVersion = '1.5'
object BRefreshFolders: TButton
Left = 104
Height = 25
Top = 8
Width = 120
Caption = 'Refresh'
OnClick = BRefreshFoldersClick
TabOrder = 0
end
object GBAccess: TGroupBox
Left = 0
Height = 91
Top = 545
Width = 1025
Align = alBottom
Caption = 'Please provide Google API access code'
ClientHeight = 63
ClientWidth = 1021
TabOrder = 1
Visible = False
object LEAccess: TLabel
Left = 16
Height = 12
Top = 8
Width = 56
Caption = 'Access code'
ParentColor = False
end
object BSetAccess: TButton
Left = 792
Height = 33
Top = 0
Width = 107
Anchors = [akTop, akRight]
Caption = 'OK'
OnClick = BSetAccessClick
TabOrder = 0
end
object BCancel: TButton
Left = 904
Height = 33
Top = 0
Width = 106
Anchors = [akTop, akRight]
Caption = 'Cancel'
OnClick = BCancelClick
TabOrder = 1
end
object EAccessCode: TEdit
Left = 144
Height = 18
Top = 2
Width = 648
Anchors = [akTop, akLeft, akRight]
TabOrder = 2
end
end
object BRefreshFiles: TButton
Left = 883
Height = 25
Top = 8
Width = 112
Anchors = [akTop, akRight]
Caption = 'Refresh'
Enabled = False
OnClick = BRefreshFilesClick
TabOrder = 2
end
object LMails: TLabel
Left = 392
Height = 12
Top = 8
Width = 484
Anchors = [akTop, akLeft, akRight]
Caption = 'Messages with label'
ParentColor = False
end
object LLabels: TLabel
Left = 24
Height = 12
Top = 8
Width = 30
Caption = 'Labels'
ParentColor = False
end
object TVLabels: TTreeView
Left = 8
Height = 512
Top = 40
Width = 344
Anchors = [akTop, akLeft, akBottom]
DefaultItemHeight = 14
ReadOnly = True
TabOrder = 3
OnSelectionChanged = TVLabelsSelectionChanged
Options = [tvoAutoItemHeight, tvoHideSelection, tvoKeepCollapsedNodes, tvoReadOnly, tvoShowButtons, tvoShowLines, tvoShowRoot, tvoToolTips, tvoThemedDraw]
end
object LVMessages: TListView
Left = 392
Height = 512
Top = 32
Width = 629
Anchors = [akTop, akLeft, akRight, akBottom]
Columns = <
item
Caption = 'Title'
Width = 200
end
item
Caption = 'From'
Width = 200
end
item
Caption = 'Received'
Width = 200
end
item
Caption = 'Recipient'
Width = 200
end
item
Caption = 'Sender'
Width = 200
end
item
Caption = 'Snippet'
Width = 300
end>
TabOrder = 4
ViewStyle = vsReport
OnDblClick = LVMessagesDblClick
end
object SDDownload: TSaveDialog
left = 415
top = 163
end
end

446
components/googleapis/demo/gmail/frmmain.pp Normal file
View File

@ -0,0 +1,446 @@
unit frmmain;
// Define USESYNAPSE if you want to force use of synapse
{ $DEFINE USESYNAPSE}
// For version 2.6.4, synapse is the only option.
{$IFDEF VER2_6}
{$DEFINE USESYNAPSE}
{$ENDIF}
{$mode objfpc}{$H+}
interface
uses
googlegmail, Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
ComCtrls, synautil, IniFiles, googlebase, googleservice, googleclient;
Const
ILeaf = 0;
ILeafEmpty = 1;
type
{ TMainForm }
TAccessTokenState = (acsWaiting,acsOK,acsCancel);
TMainForm = class(TForm)
BCancel: TButton;
BSetAccess: TButton;
BRefreshFolders: TButton;
BRefreshFiles: TButton;
EAccessCode: TEdit;
GBAccess: TGroupBox;
LLabels: TLabel;
LVMessages: TListView;
LMails: TLabel;
LEAccess: TLabel;
SDDownload: TSaveDialog;
TVLabels: TTreeView;
procedure BCancelClick(Sender: TObject);
procedure BRefreshFilesClick(Sender: TObject);
procedure BSetAccessClick(Sender: TObject);
procedure BRefreshFoldersClick(Sender: TObject);
Procedure DoUserConsent(Const AURL : String; Out AAuthCode : String) ;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure LVMessagesDblClick(Sender: TObject);
procedure TVLabelsSelectionChanged(Sender: TObject);
private
{ private declarations }
FAccessState : TAccessTokenState;
FClient : TGoogleClient;
FGmailAPI: TGmailAPI;
procedure AddLabels;
procedure ClearMailListView;
procedure ClearTreeView;
function CreateNodeWithTextPath(TextPath: string): TTreeNode;
procedure LoadAuthConfig;
procedure SaveRefreshToken;
procedure ShowLabel(ALabelID: String);
public
{ public declarations }
end;
var
MainForm: TMainForm;
implementation
uses
strutils,
ssl_openssl,
jsonparser, // needed
fpjson,
fpoauth2,
lclintf,
fpwebclient,
{$IFDEF USESYNAPSE}
ssl_openssl,
synapsewebclient
{$ELSE}
fphttpwebclient
{$ENDIF}
;
{$R *.lfm}
{ TMainForm }
procedure TMainForm.FormCreate(Sender: TObject);
begin
// Register Tasks resources.
TGmailAPI.RegisterAPIResources;
// Set up google client.
FClient:=TGoogleClient.Create(Self);
{$IFDEF USESYNAPSE}
FClient.WebClient:=TSynapseWebClient.Create(Self);
{$ELSE}
FClient.WebClient:=TFPHTTPWebClient.Create(Self);
{$ENDIF}
FClient.WebClient.RequestSigner:=FClient.AuthHandler;
FClient.WebClient.LogFile:='requests.log';
FClient.AuthHandler.WebClient:=FClient.WebClient;
FClient.AuthHandler.Config.AccessType:=atOffLine;
// We want to enter a code.
FClient.OnUserConsent:=@DoUserConsent;
// Create a Tasks API and connect it to the client.
FGmailAPI:=TGmailAPI.Create(Self);
FGmailAPI.GoogleClient:=FClient;
end;
procedure TMainForm.FormDestroy(Sender: TObject);
begin
end;
procedure TMainForm.LVMessagesDblClick(Sender: TObject);
Var
Entry : TMessage;
Request : TWebClientRequest;
Response: TWebClientResponse;
S,URL,LFN: String;
D : TJSONEnum;
begin
If Not (Assigned(LVMessages.Selected) and Assigned(LVMessages.Selected.Data)) then
Exit;
Entry:=TMessage(LVMessages.Selected.Data);
// Add some code here to show the message
end;
procedure TMainForm.TVLabelsSelectionChanged(Sender: TObject);
begin
BRefreshFilesClick(Sender)
end;
procedure TMainForm.LoadAuthConfig;
Var
ini:TIniFile;
begin
ini:=TIniFile.Create('google.ini');
try
// Registered application needs tasks scope
FClient.AuthHandler.Config.ClientID:=ini.ReadString('Credentials','ClientID','');;
FClient.AuthHandler.Config.ClientSecret:=ini.ReadString('Credentials','ClientSecret','');
FClient.AuthHandler.Config.AuthScope:=ini.ReadString('Credentials','Scope','https://www.googleapis.com/auth/drive');
// We are offline.
FClient.AuthHandler.Config.RedirectUri:='urn:ietf:wg:oauth:2.0:oob';
// Session data
FClient.AuthHandler.Session.RefreshToken:=ini.ReadString('Session','RefreshToken','');
FClient.AuthHandler.Session.AccessToken:=ini.ReadString('Session','AccesToken','');
FClient.AuthHandler.Session.AuthTokenType:=ini.ReadString('Session','TokenType','');
FClient.AuthHandler.Session.AuthExpires:=ini.ReadDateTime('Session','AuthExpires',0);
FClient.AuthHandler.Session.AuthExpiryPeriod:=Ini.ReadInteger('Session','AuthPeriod',0);
finally
Ini.Free;
end;
end;
procedure TMainForm.SaveRefreshToken;
Var
ini:TIniFile;
begin
// We save the refresh token for later use.
if FClient.AuthHandler.Session.RefreshToken<>'' then
begin
ini:=TIniFile.Create('google.ini');
try
ini.WriteString('Session','RefreshToken',FClient.AuthHandler.Session.RefreshToken);
ini.WriteString('Session','AccessToken',FClient.AuthHandler.Session.AccessToken);
ini.WriteString('Session','TokenType',FClient.AuthHandler.Session.AuthTokenType);
ini.WriteDateTime('Session','AuthExpires',FClient.AuthHandler.Session.AuthExpires);
ini.WriteInteger('Session','AuthPeriod',FClient.AuthHandler.Session.AuthExpiryPeriod);
finally
Ini.Free;
end;
end;
end;
procedure TMainForm.ClearTreeView;
Var
I : Integer;
begin
With TVLabels.Items do
begin
BeginUpdate;
try
For I:=0 to Count-1 do
TObject(Item[i].Data).Free;
Clear;
finally
EndUpdate;
end;
end;
end;
function TMainForm.CreateNodeWithTextPath(TextPath: string): TTreeNode;
var
p: SizeInt;
CurText: String;
AParent : TTreeNode;
begin
Result:=nil;
AParent:=Nil;
repeat
p:=System.Pos('/',TextPath);
if p>0 then
begin
CurText:=LeftStr(TextPath,p-1);
System.Delete(TextPath,1,p);
end
else
begin
CurText:=TextPath;
TextPath:='';
end;
//debugln(['TTreeNodes.FindNodeWithTextPath CurText=',CurText,' Rest=',TextPath]);
if AParent=nil then
Result:=TVLabels.Items.FindTopLvlNode(CurText)
else
Result:=AParent.FindNode(CurText);
if (Result=Nil) Then
Result:=TVLabels.Items.AddChild(AParent,CurText);
AParent:=Result;
until (Result=nil) or (TextPath='');
end;
procedure TMainForm.AddLabels;
var
EF,Entry: googlegmail.TLabel;
Resource : TUsersLabelsResource;
EN : String;
List : TListLabelsResponse;
i : integer;
PN,N : TTreeNode;
ShowThisLabel : boolean;
begin
Resource:=Nil;
List:=Nil;
Entry:=Nil;
try
Resource:=FGmailAPI.CreateUsersLabelsResource(Self);
// Search for folders of indicated folder only.
List:=Resource.list('me');
SaveRefreshToken;
With TVLabels.Items do
begin
BeginUpdate;
try
I:=0;
if Assigned(List) then
for Entry in List.Labels do
begin
List.Labels[i]:=Nil;
Inc(I);
ShowThisLabel:=False;
Case lowercase(Entry.labelListVisibility) of
'labelhide' : ShowThisLabel:=False;
'labelshow' : ShowThisLabel:=True;
'labelshowifunread' : ShowThisLabel:=Entry.messagesUnread>0;
end;
if not ShowThisLabel then
begin
EF:=Entry;
FreeAndNil(EF);
end
else
begin
N:=CreateNodeWithTextPath(Entry.Name);
N.Data:=Entry;
end;
end;
finally
EndUpdate;
end;
end;
Application.ProcessMessages;
finally
FreeAndNil(List);
FreeAndNil(Resource);
end;
end;
procedure TMainForm.BRefreshFoldersClick(Sender: TObject);
begin
LoadAuthConfig;
ClearTreeView;
AddLabels;
TVLabels.SortType:=stText;
end;
procedure TMainForm.BSetAccessClick(Sender: TObject);
begin
FAccessState:=acsOK;
GBAccess.Visible:=False;
end;
procedure TMainForm.BCancelClick(Sender: TObject);
begin
FAccessState:=acsCancel;
GBAccess.Visible:=False;
end;
procedure TMainForm.ClearMailListView;
Var
I : Integer;
begin
With LVMessages.Items do
begin
BeginUpdate;
try
For I:=0 to Count-1 do
TObject(Item[i].Data).Free;
Clear;
finally
EndUpdate;
end;
end;
end;
procedure TMainForm.BRefreshFilesClick(Sender: TObject);
begin
if (TVLabels.Selected=Nil) or (TVLabels.Selected.Data=Nil) then
ShowLabel('root')
else
ShowLabel(googlegmail.TLabel(TVLabels.Selected.Data).id);
end;
procedure TMainForm.ShowLabel(ALabelID: String);
Type
TMailDescription = Record
Subject : String;
Sender : String;
From : String;
Recipient : String;
Received : String;
Snippet : String;
end;
Procedure CreateDesc(E : TMessage; var Desc : TMailDescription);
Var
H : TMessagePartHeader;
begin
Desc.Subject:='';
Desc.Sender:='';
Desc.Received:='';
Desc.from:='';
Desc.Recipient:='';
Desc.Snippet:=E.snippet;
If Assigned(E.payload) then
For H in E.payload.headers do
Case LowerCase(h.name) of
'subject' : Desc.Subject:=H.value;
'sender' : Desc.Sender:=H.value;
'received' : Desc.Received:=H.Value;
'date' : Desc.Received:=H.Value;
'from' : Desc.from:=H.Value;
'to' : Desc.Recipient:=H.Value;
end;
end;
var
Msg,Entry: Tmessage;
EN : String;
i:integer;
Q : TUsersMessagesListOptions;
Resource : TUsersMessagesResource;
List : TListMessagesResponse;
LI : TListItem;
Desc : TMailDescription;
begin
ClearMailListView;
Resource:=Nil;
try
Resource:=FGmailAPI.CreateusersMessagesResource(Self);
// Search for files of indicated folder only.
Q.labelIds:=ALabelID;
List:=Resource.list('me',Q);
SaveRefreshToken;
With LVMessages.Items do
begin
BeginUpdate;
try
Clear;
if Assigned(List) then
for Msg in List.messages do
begin
Entry:=Resource.Get(Msg.id,'me','format=full');
LI:=Add;
CreateDesc(Entry,Desc);
LI.Caption:=Desc.Subject;
With LI.SubItems do
begin
Add(Desc.From);
Add(Desc.Received);
Add(Desc.Recipient);
Add(Desc.Sender);
Add(Desc.Snippet);
end;
Li.Data:=Entry;
Application.ProcessMessages;
end;
finally
EndUpdate;
end;
end;
Finally
Resource.Free;
end;
end;
Procedure TMainForm.DoUserConsent(Const AURL: String; Out AAuthCode: String);
begin
GBAccess.Visible:=True;
EAccessCode.Text:='<enter code here>';
FAccessState:=acsWaiting;
OpenUrl(AURL);
While (FAccessState=acsWaiting) do
Application.ProcessMessages;
if FAccessState=acsOK then
AAuthCode:=EAccessCode.Text;
GBAccess.Visible:=False;
end;
end.

BIN
components/googleapis/demo/gmail/gmaildemo.ico Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 134 KiB

86
components/googleapis/demo/gmail/gmaildemo.lpi Normal file
View File

@ -0,0 +1,86 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="9"/>
<General>
<Flags>
<SaveOnlyProjectUnits Value="True"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="gmaildemo"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<Icon Value="0"/>
</General>
<i18n>
<EnableI18N LFM="False"/>
</i18n>
<VersionInfo>
<StringTable ProductVersion=""/>
</VersionInfo>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
</local>
</RunParams>
<RequiredPackages Count="2">
<Item1>
<PackageName Value="laz_synapse"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
</Item2>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="gmaildemo.lpr"/>
<IsPartOfProject Value="True"/>
</Unit0>
<Unit1>
<Filename Value="frmmain.pp"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="MainForm"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<Target>
<Filename Value="gmaildemo"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<OtherUnitFiles Value="../..;../../../base;../../apis"/>
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

20
components/googleapis/demo/gmail/gmaildemo.lpr Normal file
View File

@ -0,0 +1,20 @@
program gmaildemo;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms, frmmain;
{$R *.res}
begin
RequireDerivedFormResource := True;
Application.Initialize;
Application.CreateForm(TMainForm, MainForm);
Application.Run;
end.

BIN
components/googleapis/demo/gmail/gmaildemo.res Normal file
View File

Binary file not shown.

5
components/googleapis/demo/gmail/google.ini Normal file
View File

@ -0,0 +1,5 @@
[Credentials]
ClientID=Your client ID
ClientSecret=Your secret key
Scope=https://mail.google.com/