├── README.md
├── frmmain_full.lfm
├── frmmain_full.pas
├── frmmain_gmail.lfm
├── frmmain_gmail.pas
├── google_calendar.pas
├── google_drive.pas
├── google_oauth2.pas
├── test_full.lpi
├── test_full.lpr
├── test_gmail.lpi
└── test_gmail.lpr
/README.md:
--------------------------------------------------------------------------------
1 | google-oauth2.0
2 | =================
3 |
4 | Small simple FPC library for implementing Google OAuth 2.0
5 |
6 | This can be used to do XOAUTH2 for sending mail via GMail
7 |
8 |
9 | Requirements
10 | ============
11 |
12 | * FPC 2.6.4+ (others untested)
13 | * Synapse 40+
14 | * libeay32.dll
15 | * libssl32.dll
16 | * ssleay32.dll
17 |
18 | How does it work?
19 | =================
20 |
21 | First of all, for your own project you'll need to create your own credentials.
22 | The ones provides only works for my own test-address/account.
23 | After you have tested your app you need to go through a pubisch/review process.
24 |
25 | https://console.developers.google.com/apis/credentials
26 | * Create a "New Project"
27 | * Give the project a name and click "Create"
28 | * Select the project and click upper left 3 lines button
29 | * Wait for the creation of the project until the button "Select Project" is visible
30 | * Click "Select Project"
31 | * Click "Enable Apis and Services"
32 | * If you want GMail/SMTP access search gmail and Enable "Gmail API"
33 | * If you want Calendar access search calendar and Enable "Google Calendar API"
34 | * If you want Drive access search drive and Enable "Google Drive API"
35 | * If you want Contacts access search contacts and Enable "Contacts API"
36 | * Click "OAuth consent screen"
37 | * Choose "External" (Internal is only available for Google Workspace users)
38 | * Fill out the consent screen
39 | * Click "Save and continue"
40 | * At the scopes click "Add or remove scopes"
41 | * Check ".../auth/userinfo.email" and ".../auth/userinfo.profile" (first 2)
42 | * If you want GMail/SMTP access seach gmail (in the filter) and add "https://mail.google.com/"
43 | * If you want Calendar access search calendar and add https://www.googleapis.com/auth/calendar
44 | * If you want Drive access search drive and add https://www.googleapis.com/auth/drive
45 | * If you want Contact access search contacts and add https://www.google.com/m8/feeds
46 | * Press the "Update" button
47 | * Click "Save and continue"
48 | * Click "Add Users" at the "Test users" screen
49 | * Enter your own e-mail adres as test-user and click "Add"
50 | * Click "Save and continue"
51 | * Click "Credentials"
52 | * Click "Create Credentials"
53 | * Choose "OAuth client ID"
54 | * Choose "Desktop app" and name it
55 | * Click "Create"
56 | * Click the "Download JSON" and save the .json file
57 | * Click "Ok"
58 |
59 | Now copy the client_secret_xxx.json to client.json in your app directory
60 | Run the program, click "Remove token.dat" and click "Get Access"
61 | Choose your test-address account and click continue
62 | Make sure to check the All mail GMail checkbox in the authentication screen
63 | and click "Continue"
64 |
65 | The program should now give the message "We now have access" in the memo-screen
66 | You can click the "Send mail" to send a test message
67 |
68 | ~~Currently the provided credentials do work for the test-application.~~
69 | The provided credentials do not work for other users. You need to register your own with the prcedure described above.
70 |
71 | Note: The sope for composing mail `https://www.googleapis.com/auth/gmail.compose` is not
72 | enhough to mail via smtp. Smtp access requires full mail-access (https://mail.google.com/).
73 |
74 | Further Resources
75 | =================
76 | * https://developers.google.com/accounts/docs/OAuth2InstalledApp
77 | * https://developers.google.com/oauthplayground/
78 | * https://developers.google.com/accounts/docs/OAuth2
79 | * https://developers.google.com/google-apps/gmail/oauth_overview
80 | * https://developers.google.com/google-apps/calendar/
81 | * http://masashi-k.blogspot.nl/2013/06/sending-mail-with-gmail-using-xoauth2.html
82 |
83 | Synapse requirement
84 | =================
85 | For communication Synapse from Ararat is used. You can download the latest version from https://sourceforge.net/p/synalist/code/HEAD/tree/trunk/
86 | (at the top-right is a "Download snapshot"-button. Put it somewhere and in Lazarus you can choose "Package" > "Open package file".
87 | Browse to the folder for synapse and choose laz_synapse.lpk.
88 | Extra step is to add the ssl_openssl.pas before compiling for HTTPS access.
89 | You don't need to install anything. laz_synapse will now be available as package.
90 | You also need the openssl DLLs in your project directory (or search-path). libeay32.dll, libssl32.dll and ssleay32.dll.
91 |
92 | Todo
93 | ====
94 |
95 | * Improve the documentation and comments
96 | * Create a TDataset-like descendant for Calendar and EMail access
97 |
98 |
--------------------------------------------------------------------------------
/frmmain_full.lfm:
--------------------------------------------------------------------------------
1 | object Mainform: TMainform
2 | Left = 256
3 | Height = 696
4 | Top = 195
5 | Width = 1147
6 | Caption = 'Google OAuth 2.0 testapp'
7 | ClientHeight = 696
8 | ClientWidth = 1147
9 | OnCreate = FormCreate
10 | OnDestroy = FormDestroy
11 | OnShow = FormShow
12 | Position = poScreenCenter
13 | LCLVersion = '2.3.0.0'
14 | object PageControl6: TPageControl
15 | Left = 0
16 | Height = 696
17 | Top = 0
18 | Width = 1147
19 | ActivePage = TabSheet14
20 | Align = alClient
21 | TabIndex = 0
22 | TabOrder = 0
23 | object TabSheet14: TTabSheet
24 | Caption = 'Google Access'
25 | ClientHeight = 668
26 | ClientWidth = 1139
27 | object Panel1: TPanel
28 | Left = 0
29 | Height = 270
30 | Top = 0
31 | Width = 1139
32 | Align = alTop
33 | ClientHeight = 270
34 | ClientWidth = 1139
35 | TabOrder = 0
36 | object btGetAccess: TButton
37 | Left = 136
38 | Height = 25
39 | Top = 16
40 | Width = 120
41 | Caption = 'Get access'
42 | OnClick = btGetAccessClick
43 | TabOrder = 0
44 | end
45 | object Memo1: TMemo
46 | Left = 11
47 | Height = 111
48 | Top = 148
49 | Width = 1117
50 | Align = alBottom
51 | BorderSpacing.Around = 10
52 | ScrollBars = ssAutoVertical
53 | TabOrder = 1
54 | end
55 | object btRemoveTokens: TButton
56 | Left = 272
57 | Height = 25
58 | Top = 16
59 | Width = 147
60 | Caption = 'Remove tokens.dat'
61 | OnClick = btRemoveTokensClick
62 | TabOrder = 2
63 | end
64 | object btClearLog: TButton
65 | Left = 24
66 | Height = 25
67 | Top = 16
68 | Width = 99
69 | Caption = 'Clear debug'
70 | OnClick = btClearLogClick
71 | TabOrder = 3
72 | end
73 | object CheckGroup1: TCheckGroup
74 | Left = 24
75 | Height = 96
76 | Top = 48
77 | Width = 1095
78 | Anchors = [akTop, akLeft, akRight]
79 | AutoFill = True
80 | Caption = 'Access (scope)'
81 | ChildSizing.LeftRightSpacing = 6
82 | ChildSizing.TopBottomSpacing = 6
83 | ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
84 | ChildSizing.EnlargeVertical = crsHomogenousChildResize
85 | ChildSizing.ShrinkHorizontal = crsScaleChilds
86 | ChildSizing.ShrinkVertical = crsScaleChilds
87 | ChildSizing.Layout = cclTopToBottomThenLeftToRight
88 | ChildSizing.ControlsPerLine = 2
89 | ClientHeight = 76
90 | ClientWidth = 1091
91 | ColumnLayout = clVerticalThenHorizontal
92 | Columns = 3
93 | Items.Strings = (
94 | 'profile (info only)'
95 | 'email (info only)'
96 | 'Access to Mail'
97 | 'Access to Contacts'
98 | 'Access to Calendar'
99 | 'Access to Drive'
100 | )
101 | TabOrder = 4
102 | Data = {
103 | 06000000020202020202
104 | }
105 | end
106 | end
107 | object PageControl1: TPageControl
108 | Left = 0
109 | Height = 398
110 | Top = 270
111 | Width = 1139
112 | ActivePage = TabSheet9
113 | Align = alClient
114 | TabIndex = 1
115 | TabOrder = 1
116 | object TabSheet1: TTabSheet
117 | Caption = 'GMail'
118 | ClientHeight = 370
119 | ClientWidth = 1131
120 | object PageControl2: TPageControl
121 | Left = 10
122 | Height = 350
123 | Top = 10
124 | Width = 1111
125 | ActivePage = TabSheet4
126 | Align = alClient
127 | BorderSpacing.Around = 10
128 | TabIndex = 0
129 | TabOrder = 0
130 | object TabSheet4: TTabSheet
131 | Caption = 'New mail'
132 | ClientHeight = 322
133 | ClientWidth = 1103
134 | object Label1: TLabel
135 | Left = 144
136 | Height = 23
137 | Top = 16
138 | Width = 55
139 | Alignment = taRightJustify
140 | AutoSize = False
141 | Caption = 'From'
142 | Font.Height = -16
143 | Layout = tlCenter
144 | ParentColor = False
145 | ParentFont = False
146 | end
147 | object edSender: TEdit
148 | Left = 216
149 | Height = 23
150 | Top = 16
151 | Width = 877
152 | Anchors = [akTop, akLeft, akRight]
153 | Enabled = False
154 | TabOrder = 0
155 | Text = '(will be filled in automatically during send or GetAccess)'
156 | end
157 | object Label2: TLabel
158 | Left = 144
159 | Height = 23
160 | Top = 48
161 | Width = 56
162 | Alignment = taRightJustify
163 | AutoSize = False
164 | Caption = 'To'
165 | Font.Height = -16
166 | Layout = tlCenter
167 | ParentColor = False
168 | ParentFont = False
169 | end
170 | object edRecipient: TEdit
171 | Left = 216
172 | Height = 23
173 | Top = 48
174 | Width = 877
175 | Anchors = [akTop, akLeft, akRight]
176 | TabOrder = 1
177 | Text = 'recipient@valid_domain.com'
178 | end
179 | object Label3: TLabel
180 | Left = 144
181 | Height = 23
182 | Top = 80
183 | Width = 55
184 | Alignment = taRightJustify
185 | AutoSize = False
186 | Caption = 'Subject'
187 | Font.Height = -16
188 | Layout = tlCenter
189 | ParentColor = False
190 | ParentFont = False
191 | end
192 | object edSubject: TEdit
193 | Left = 216
194 | Height = 23
195 | Top = 80
196 | Width = 877
197 | Anchors = [akTop, akLeft, akRight]
198 | TabOrder = 2
199 | Text = 'Subject'
200 | end
201 | object edBody: TMemo
202 | Left = 10
203 | Height = 199
204 | Top = 113
205 | Width = 1083
206 | Align = alBottom
207 | Anchors = [akTop, akLeft, akRight, akBottom]
208 | BorderSpacing.Around = 10
209 | Lines.Strings = (
210 | 'This is the body of the mail'
211 | )
212 | TabOrder = 3
213 | end
214 | object btSendMail: TButton
215 | Left = 10
216 | Height = 88
217 | Top = 15
218 | Width = 118
219 | Caption = 'Send mail'
220 | OnClick = btSendMailClick
221 | TabOrder = 4
222 | end
223 | end
224 | object TabSheet5: TTabSheet
225 | Caption = 'Inbox'
226 | end
227 | end
228 | end
229 | object TabSheet9: TTabSheet
230 | Caption = 'Contacts'
231 | ClientHeight = 370
232 | ClientWidth = 1131
233 | object PageControl4: TPageControl
234 | Left = 10
235 | Height = 350
236 | Top = 10
237 | Width = 1111
238 | ActivePage = TabSheet11
239 | Align = alClient
240 | BorderSpacing.Around = 10
241 | TabIndex = 1
242 | TabOrder = 0
243 | object TabSheet10: TTabSheet
244 | Caption = 'New contact'
245 | ClientHeight = 322
246 | ClientWidth = 1103
247 | object Button8: TButton
248 | Left = 10
249 | Height = 88
250 | Top = 16
251 | Width = 118
252 | Caption = 'not impl. yet'
253 | TabOrder = 0
254 | end
255 | end
256 | object TabSheet11: TTabSheet
257 | Caption = 'Contacts'
258 | ClientHeight = 322
259 | ClientWidth = 1103
260 | object btGetContacts: TButton
261 | Left = 8
262 | Height = 25
263 | Top = 8
264 | Width = 168
265 | Caption = 'Get all contacts'
266 | OnClick = btGetContactsClick
267 | TabOrder = 0
268 | end
269 | object StringGrid2: TStringGrid
270 | Left = 10
271 | Height = 264
272 | Top = 48
273 | Width = 1083
274 | Align = alBottom
275 | Anchors = [akTop, akLeft, akRight, akBottom]
276 | BorderSpacing.Around = 10
277 | TabOrder = 1
278 | end
279 | end
280 | end
281 | end
282 | object TabSheet2: TTabSheet
283 | Caption = 'Calendar'
284 | ClientHeight = 370
285 | ClientWidth = 1131
286 | object PageControl3: TPageControl
287 | Left = 10
288 | Height = 350
289 | Top = 10
290 | Width = 1111
291 | ActivePage = TabSheet6
292 | Align = alClient
293 | BorderSpacing.Around = 10
294 | TabIndex = 0
295 | TabOrder = 0
296 | object TabSheet6: TTabSheet
297 | Caption = 'New appointment'
298 | ClientHeight = 322
299 | ClientWidth = 1103
300 | object Button5: TButton
301 | Left = 10
302 | Height = 88
303 | Top = 16
304 | Width = 118
305 | Caption = 'Add event'
306 | OnClick = Button5Click
307 | TabOrder = 0
308 | end
309 | object edTitle: TEdit
310 | Left = 248
311 | Height = 23
312 | Top = 16
313 | Width = 260
314 | TabOrder = 1
315 | Text = 'edTitle'
316 | end
317 | object edDescription: TEdit
318 | Left = 248
319 | Height = 23
320 | Top = 46
321 | Width = 260
322 | TabOrder = 2
323 | Text = 'edDescription'
324 | end
325 | object edStart: TDateEdit
326 | Left = 248
327 | Height = 23
328 | Top = 110
329 | Width = 260
330 | CalendarDisplaySettings = [dsShowHeadings, dsShowDayNames]
331 | DateOrder = doNone
332 | ButtonWidth = 23
333 | NumGlyphs = 1
334 | MaxLength = 0
335 | TabOrder = 4
336 | Text = 'edStart'
337 | end
338 | object edEnd: TDateEdit
339 | Left = 248
340 | Height = 23
341 | Top = 142
342 | Width = 260
343 | CalendarDisplaySettings = [dsShowHeadings, dsShowDayNames]
344 | DateOrder = doNone
345 | ButtonWidth = 23
346 | NumGlyphs = 1
347 | MaxLength = 0
348 | TabOrder = 5
349 | Text = 'edEnd'
350 | end
351 | object edLocation: TEdit
352 | Left = 248
353 | Height = 23
354 | Top = 74
355 | Width = 260
356 | TabOrder = 3
357 | Text = 'edLocation'
358 | end
359 | object Summary: TLabel
360 | Left = 175
361 | Height = 15
362 | Top = 21
363 | Width = 51
364 | Caption = 'Summary'
365 | ParentColor = False
366 | end
367 | object Summary1: TLabel
368 | Left = 176
369 | Height = 15
370 | Top = 48
371 | Width = 60
372 | Caption = 'Description'
373 | ParentColor = False
374 | end
375 | object Summary2: TLabel
376 | Left = 175
377 | Height = 15
378 | Top = 80
379 | Width = 46
380 | Caption = 'Location'
381 | ParentColor = False
382 | end
383 | object Summary3: TLabel
384 | Left = 180
385 | Height = 15
386 | Top = 112
387 | Width = 24
388 | Caption = 'Start'
389 | ParentColor = False
390 | end
391 | object Summary4: TLabel
392 | Left = 184
393 | Height = 15
394 | Top = 144
395 | Width = 20
396 | Caption = 'End'
397 | ParentColor = False
398 | end
399 | end
400 | object TabSheet7: TTabSheet
401 | Caption = 'Calendar'
402 | ClientHeight = 322
403 | ClientWidth = 1103
404 | object btGetAppointments: TButton
405 | Left = 8
406 | Height = 25
407 | Top = 8
408 | Width = 168
409 | Caption = 'Get all appointments'
410 | OnClick = btGetAppointmentsClick
411 | TabOrder = 0
412 | end
413 | object StringGrid1: TStringGrid
414 | Left = 10
415 | Height = 264
416 | Top = 48
417 | Width = 1083
418 | Align = alBottom
419 | Anchors = [akTop, akLeft, akRight, akBottom]
420 | BorderSpacing.Around = 10
421 | TabOrder = 1
422 | OnDblClick = StringGrid1DblClick
423 | end
424 | object Edit1: TEdit
425 | Left = 665
426 | Height = 23
427 | Top = 8
428 | Width = 428
429 | Anchors = [akTop, akRight]
430 | Enabled = False
431 | TabOrder = 2
432 | Text = 'Edit1'
433 | end
434 | object Label4: TLabel
435 | Left = 633
436 | Height = 15
437 | Top = 12
438 | Width = 26
439 | Anchors = [akTop, akRight]
440 | Caption = 'Filter'
441 | ParentColor = False
442 | end
443 | end
444 | end
445 | end
446 | object TabSheet3: TTabSheet
447 | Caption = 'Drive'
448 | ClientHeight = 370
449 | ClientWidth = 1131
450 | object PageControl5: TPageControl
451 | Left = 0
452 | Height = 323
453 | Top = 0
454 | Width = 1128
455 | ActivePage = TabSheet13
456 | Align = alCustom
457 | Anchors = [akTop, akLeft, akRight, akBottom]
458 | BorderSpacing.Around = 10
459 | TabIndex = 1
460 | TabOrder = 0
461 | object TabSheet12: TTabSheet
462 | Caption = 'Upload'
463 | ClientHeight = 295
464 | ClientWidth = 1120
465 | OnShow = TabSheet12Show
466 | object btnSimpleUpload: TButton
467 | Left = 8
468 | Height = 25
469 | Top = 8
470 | Width = 134
471 | Caption = 'btnSimpleUpload'
472 | Enabled = False
473 | OnClick = btnSimpleUploadClick
474 | TabOrder = 0
475 | end
476 | object btnUploadWithResume: TButton
477 | Left = 152
478 | Height = 25
479 | Top = 8
480 | Width = 134
481 | Caption = 'btnUploadWithResume'
482 | OnClick = btnUploadWithResumeClick
483 | TabOrder = 1
484 | end
485 | object Edit3: TEdit
486 | Left = 448
487 | Height = 23
488 | Top = 10
489 | Width = 659
490 | Anchors = [akTop, akLeft, akRight]
491 | TabOrder = 2
492 | end
493 | object Label6: TLabel
494 | Left = 376
495 | Height = 15
496 | Top = 10
497 | Width = 60
498 | Caption = 'Description'
499 | ParentColor = False
500 | end
501 | object ListBox1: TListBox
502 | Left = 8
503 | Height = 244
504 | Top = 48
505 | Width = 1099
506 | Anchors = [akTop, akLeft, akRight, akBottom]
507 | ItemHeight = 0
508 | TabOrder = 3
509 | end
510 | end
511 | object TabSheet13: TTabSheet
512 | Caption = 'Files in Drive'
513 | ClientHeight = 295
514 | ClientWidth = 1120
515 | object btGetFileList: TButton
516 | Left = 8
517 | Height = 25
518 | Top = 8
519 | Width = 168
520 | Caption = 'Get all Filelist'
521 | OnClick = btGetFileListClick
522 | TabOrder = 0
523 | end
524 | object StringGrid3: TStringGrid
525 | Left = 10
526 | Height = 237
527 | Top = 48
528 | Width = 1100
529 | Align = alBottom
530 | Anchors = [akTop, akLeft, akRight, akBottom]
531 | AutoFillColumns = True
532 | BorderSpacing.Around = 10
533 | TabOrder = 1
534 | OnDblClick = StringGrid1DblClick
535 | OnKeyDown = StringGrid3KeyDown
536 | ColWidths = (
537 | 64
538 | 254
539 | 254
540 | 254
541 | 253
542 | )
543 | end
544 | object Edit2: TEdit
545 | Left = 682
546 | Height = 23
547 | Top = 8
548 | Width = 428
549 | Anchors = [akTop, akRight]
550 | Enabled = False
551 | TabOrder = 2
552 | Text = 'Edit1'
553 | end
554 | object Label5: TLabel
555 | Left = 650
556 | Height = 15
557 | Top = 12
558 | Width = 26
559 | Anchors = [akTop, akRight]
560 | Caption = 'Filter'
561 | ParentColor = False
562 | end
563 | object ckHideFolders: TCheckBox
564 | Left = 192
565 | Height = 19
566 | Top = 8
567 | Width = 84
568 | Caption = 'Hide Folders'
569 | OnClick = ckHideFoldersClick
570 | TabOrder = 3
571 | end
572 | object Button2: TButton
573 | Left = 320
574 | Height = 25
575 | Top = 8
576 | Width = 67
577 | Caption = 'List 2'
578 | Enabled = False
579 | OnClick = Button2Click
580 | TabOrder = 4
581 | end
582 | end
583 | object TabSheet16: TTabSheet
584 | Caption = 'Revisions in File'
585 | ClientHeight = 295
586 | ClientWidth = 1120
587 | object StringGrid4: TStringGrid
588 | Left = 10
589 | Height = 237
590 | Top = 48
591 | Width = 1100
592 | Align = alBottom
593 | Anchors = [akTop, akLeft, akRight, akBottom]
594 | AutoFillColumns = True
595 | BorderSpacing.Around = 10
596 | TabOrder = 0
597 | OnDblClick = StringGrid4DblClick
598 | OnKeyDown = StringGrid3KeyDown
599 | ColWidths = (
600 | 64
601 | 254
602 | 254
603 | 254
604 | 253
605 | )
606 | end
607 | object Button3: TButton
608 | Left = 8
609 | Height = 25
610 | Top = 10
611 | Width = 179
612 | Caption = 'Delete selected'
613 | OnClick = Button3Click
614 | TabOrder = 1
615 | end
616 | object Button4: TButton
617 | Left = 201
618 | Height = 25
619 | Top = 10
620 | Width = 163
621 | Caption = 'Upload a revision'
622 | OnClick = Button4Click
623 | TabOrder = 2
624 | end
625 | end
626 | end
627 | object ProgressBar1: TProgressBar
628 | Left = 24
629 | Height = 20
630 | Top = 340
631 | Width = 1082
632 | Anchors = [akLeft, akRight, akBottom]
633 | TabOrder = 1
634 | end
635 | end
636 | object TabSheet8: TTabSheet
637 | Caption = 'Debug'
638 | ClientHeight = 370
639 | ClientWidth = 1131
640 | object Memo2: TMemo
641 | Left = 10
642 | Height = 315
643 | Top = 45
644 | Width = 1111
645 | Align = alClient
646 | BorderSpacing.Around = 10
647 | Lines.Strings = (
648 | 'Memo2'
649 | )
650 | ScrollBars = ssAutoVertical
651 | TabOrder = 0
652 | end
653 | object btClearDebug: TButton
654 | Left = 10
655 | Height = 25
656 | Top = 10
657 | Width = 1111
658 | Align = alTop
659 | BorderSpacing.Around = 10
660 | Caption = 'Clear debugscreen'
661 | OnClick = btClearDebugClick
662 | TabOrder = 1
663 | end
664 | end
665 | end
666 | end
667 | object TabSheet15: TTabSheet
668 | Caption = 'Google Drive'
669 | ClientHeight = 668
670 | ClientWidth = 1139
671 | object TreeView1: TTreeView
672 | Left = 0
673 | Height = 577
674 | Top = 48
675 | Width = 209
676 | Align = alLeft
677 | RowSelect = True
678 | TabOrder = 0
679 | OnClick = TreeView1Click
680 | OnSelectionChanged = TreeView1SelectionChanged
681 | Options = [tvoAutoItemHeight, tvoHideSelection, tvoKeepCollapsedNodes, tvoRowSelect, tvoShowButtons, tvoShowLines, tvoShowRoot, tvoToolTips, tvoThemedDraw]
682 | end
683 | object Panel2: TPanel
684 | Left = 0
685 | Height = 48
686 | Top = 0
687 | Width = 1139
688 | Align = alTop
689 | Caption = 'Panel2'
690 | ClientHeight = 48
691 | ClientWidth = 1139
692 | TabOrder = 1
693 | object Button1: TButton
694 | Left = 8
695 | Height = 25
696 | Top = 8
697 | Width = 75
698 | Caption = 'Connect'
699 | OnClick = Button1Click
700 | TabOrder = 0
701 | end
702 | object Edit4: TEdit
703 | Left = 890
704 | Height = 23
705 | Top = 10
706 | Width = 236
707 | Anchors = [akTop, akRight]
708 | Enabled = False
709 | TabOrder = 1
710 | Text = 'Edit1'
711 | end
712 | object Label7: TLabel
713 | Left = 858
714 | Height = 15
715 | Top = 14
716 | Width = 26
717 | Anchors = [akTop, akRight]
718 | Caption = 'Filter'
719 | ParentColor = False
720 | end
721 | object listmthd: TCheckBox
722 | Left = 112
723 | Height = 19
724 | Top = 13
725 | Width = 87
726 | Caption = 'list method 2'
727 | Checked = True
728 | State = cbChecked
729 | TabOrder = 2
730 | end
731 | object Button6: TButton
732 | Left = 239
733 | Height = 25
734 | Top = 8
735 | Width = 115
736 | Caption = 'Pause / Cancel'
737 | OnClick = Button6Click
738 | TabOrder = 3
739 | end
740 | end
741 | object StatusBar1: TStatusBar
742 | Left = 0
743 | Height = 23
744 | Top = 645
745 | Width = 1139
746 | Panels = <>
747 | end
748 | object Splitter1: TSplitter
749 | Left = 209
750 | Height = 577
751 | Top = 48
752 | Width = 15
753 | end
754 | object ProgressBar2: TProgressBar
755 | Left = 0
756 | Height = 20
757 | Top = 625
758 | Width = 1139
759 | Align = alBottom
760 | TabOrder = 4
761 | end
762 | object Panel3: TPanel
763 | Left = 224
764 | Height = 577
765 | Top = 48
766 | Width = 915
767 | Align = alClient
768 | Caption = 'Loading ... please wait'
769 | ClientHeight = 577
770 | ClientWidth = 915
771 | TabOrder = 5
772 | object ListView1: TListView
773 | Left = 0
774 | Height = 431
775 | Top = 8
776 | Width = 914
777 | Align = alCustom
778 | Anchors = [akTop, akLeft, akRight, akBottom]
779 | Columns = <
780 | item
781 | Caption = 'Name'
782 | Width = 400
783 | end
784 | item
785 | AutoSize = True
786 | Caption = 'Date modified'
787 | Width = 90
788 | end
789 | item
790 | AutoSize = True
791 | Caption = 'Type'
792 | Width = 40
793 | end
794 | item
795 | AutoSize = True
796 | Caption = 'Size'
797 | Width = 35
798 | end
799 | item
800 | AutoSize = True
801 | Caption = 'Original filename'
802 | Width = 106
803 | end>
804 | MultiSelect = True
805 | PopupMenu = PopupMenu1
806 | ReadOnly = True
807 | RowSelect = True
808 | TabOrder = 0
809 | ViewStyle = vsReport
810 | OnClick = ListView1Click
811 | OnDblClick = ListView1DblClick
812 | end
813 | object ListView2: TListView
814 | Left = 1
815 | Height = 137
816 | Top = 439
817 | Width = 913
818 | Align = alBottom
819 | Columns = <
820 | item
821 | AutoSize = True
822 | Caption = 'Revision'
823 | Width = 59
824 | end
825 | item
826 | AutoSize = True
827 | Caption = 'Date modified'
828 | Width = 90
829 | end
830 | item
831 | AutoSize = True
832 | Caption = 'Original filename'
833 | Width = 106
834 | end
835 | item
836 | AutoSize = True
837 | Caption = 'Mimetype'
838 | Width = 69
839 | end>
840 | MultiSelect = True
841 | ReadOnly = True
842 | RowSelect = True
843 | TabOrder = 1
844 | ViewStyle = vsReport
845 | OnDblClick = ListView2DblClick
846 | end
847 | end
848 | end
849 | end
850 | object ImageList1: TImageList
851 | Left = 365
852 | Top = 205
853 | end
854 | object PopupMenu1: TPopupMenu
855 | Left = 278
856 | Top = 40
857 | object MenuItem1: TMenuItem
858 | Caption = 'Download File'
859 | OnClick = MenuItem1Click
860 | end
861 | object exportmenu: TMenuItem
862 | Tag = 1
863 | Caption = 'Export'
864 | object MenuItem3: TMenuItem
865 | Tag = 2
866 | Caption = 'export'
867 | end
868 | end
869 | object MenuItem4: TMenuItem
870 | Caption = 'Delete File'
871 | OnClick = MenuItem4Click
872 | end
873 | object MenuItem2: TMenuItem
874 | Caption = '(test) show parent'
875 | OnClick = MenuItem2Click
876 | end
877 | end
878 | end
879 |
--------------------------------------------------------------------------------
/frmmain_full.pas:
--------------------------------------------------------------------------------
1 | unit frmMain_Full;
2 |
3 | {$mode objfpc}{$H+}
4 |
5 | interface
6 |
7 | uses
8 | Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
9 | ComCtrls, ExtCtrls, Grids, blcksock, fpjson, jsonConf, LMessages, EditBtn,
10 | DBCtrls, Menus, md5, google_drive;
11 |
12 | const
13 | WM_AFTER_SHOW = WM_USER + 300;
14 |
15 | type
16 |
17 | { TMainform }
18 |
19 | TMainform = class(TForm)
20 | btGetAccess: TButton;
21 | btGetFileList: TButton;
22 | btSendMail: TButton;
23 | btRemoveTokens: TButton;
24 | btClearLog: TButton;
25 | btnSimpleUpload: TButton;
26 | btnUploadWithResume: TButton;
27 | Button1: TButton;
28 | Button2: TButton;
29 | Button3: TButton;
30 | Button4: TButton;
31 | Button5: TButton;
32 | btGetAppointments: TButton;
33 | btClearDebug: TButton;
34 | Button6: TButton;
35 | Button8: TButton;
36 | btGetContacts: TButton;
37 | listmthd: TCheckBox;
38 | ckHideFolders: TCheckBox;
39 | CheckGroup1: TCheckGroup;
40 |
41 | Edit4: TEdit;
42 | edLocation: TEdit;
43 | edStart: TDateEdit;
44 | edEnd: TDateEdit;
45 |
46 |
47 | edBody: TMemo;
48 | Edit1: TEdit;
49 | Edit2: TEdit;
50 | Edit3: TEdit;
51 | edTitle: TEdit;
52 | edDescription: TEdit;
53 | edRecipient: TEdit;
54 | edSender: TEdit;
55 | edSubject: TEdit;
56 | ImageList1: TImageList;
57 | Label1: TLabel;
58 | Label2: TLabel;
59 | Label3: TLabel;
60 | Label4: TLabel;
61 | Label5: TLabel;
62 | Label6: TLabel;
63 | Label7: TLabel;
64 | ListView1: TListView;
65 | ListView2: TListView;
66 | MenuItem1: TMenuItem;
67 | exportmenu: TMenuItem;
68 | MenuItem2: TMenuItem;
69 | MenuItem3: TMenuItem;
70 | MenuItem4: TMenuItem;
71 | PageControl6: TPageControl;
72 | Panel2: TPanel;
73 | Panel3: TPanel;
74 | PopupMenu1: TPopupMenu;
75 | ProgressBar2: TProgressBar;
76 | Splitter1: TSplitter;
77 | StatusBar1: TStatusBar;
78 | StringGrid4: TStringGrid;
79 | Summary: TLabel;
80 | ListBox1: TListBox;
81 | Memo1: TMemo;
82 | Memo2: TMemo;
83 | PageControl1: TPageControl;
84 | PageControl2: TPageControl;
85 | PageControl3: TPageControl;
86 | PageControl4: TPageControl;
87 | PageControl5: TPageControl;
88 | Panel1: TPanel;
89 | ProgressBar1: TProgressBar;
90 | StringGrid1: TStringGrid;
91 | StringGrid2: TStringGrid;
92 | StringGrid3: TStringGrid;
93 | Summary1: TLabel;
94 | Summary2: TLabel;
95 | Summary3: TLabel;
96 | Summary4: TLabel;
97 | TabSheet1: TTabSheet;
98 | TabSheet10: TTabSheet;
99 | TabSheet11: TTabSheet;
100 | TabSheet12: TTabSheet;
101 | TabSheet13: TTabSheet;
102 | TabSheet14: TTabSheet;
103 | TabSheet15: TTabSheet;
104 | TabSheet16: TTabSheet;
105 | TabSheet2: TTabSheet;
106 | TabSheet3: TTabSheet;
107 | TabSheet4: TTabSheet;
108 | TabSheet5: TTabSheet;
109 | TabSheet6: TTabSheet;
110 | TabSheet7: TTabSheet;
111 | TabSheet8: TTabSheet;
112 | TabSheet9: TTabSheet;
113 | TreeView1: TTreeView;
114 | procedure btGetAccessClick(Sender: TObject);
115 | procedure btGetContactsClick(Sender: TObject);
116 | procedure btGetFileListClick(Sender: TObject);
117 | procedure btSendMailClick(Sender: TObject);
118 | procedure btRemoveTokensClick(Sender: TObject);
119 | procedure btClearLogClick(Sender: TObject);
120 | procedure btGetAppointmentsClick(Sender: TObject);
121 | procedure btClearDebugClick(Sender: TObject);
122 | procedure btnSimpleUploadClick(Sender: TObject);
123 | procedure btnUploadWithResumeClick(Sender: TObject);
124 | procedure Button1Click(Sender: TObject);
125 | procedure Button2Click(Sender: TObject);
126 | procedure Button3Click(Sender: TObject);
127 | procedure Button4Click(Sender: TObject);
128 | procedure Button5Click(Sender: TObject);
129 | procedure Button6Click(Sender: TObject);
130 | procedure Button7Click(Sender: TObject);
131 | procedure ckHideFoldersClick(Sender: TObject);
132 | procedure FormCreate(Sender: TObject);
133 | procedure FormDestroy(Sender: TObject);
134 | procedure FormShow(Sender: TObject);
135 | procedure ListView1Click(Sender: TObject);
136 | procedure ListView1DblClick(Sender: TObject);
137 | procedure ListView2DblClick(Sender: TObject);
138 | procedure MenuItem1Click(Sender: TObject);
139 | procedure MenuItem2Click(Sender: TObject);
140 | procedure MenuItem4Click(Sender: TObject);
141 | procedure StringGrid1DblClick(Sender: TObject);
142 | procedure StringGrid3KeyDown(Sender: TObject; var Key: word; Shift: TShiftState);
143 | procedure StringGrid4DblClick(Sender: TObject);
144 | procedure TabSheet12Show(Sender: TObject);
145 | procedure TreeView1Click(Sender: TObject);
146 | procedure TreeView1SelectionChanged(Sender: TObject);
147 | private
148 | { private declarations }
149 | protected
150 | procedure AfterShow(var Msg: TLMessage); message WM_AFTER_SHOW;
151 | public
152 | { public declarations }
153 | procedure ExporttoFile(Sender: TObject);
154 | procedure AddToLog(Str: string);
155 | procedure CheckTokenFile;
156 | function GetJSONParam(filename, param: string): string;
157 | procedure SetJSONParam(filename, param, Value: string);
158 | procedure DeleteJSONPath(filename, param: string);
159 | // function Download_Gdrive_File(id,auth, target: string): Boolean;
160 | procedure FillDriveGrid_old;
161 | procedure FillDriveView;
162 | procedure UploadWithResume(fileid: string = ''; settings: TUploadSettings = []);
163 | procedure FillDriveView2;
164 | end;
165 |
166 | var
167 | Mainform: TMainform;
168 |
169 |
170 | implementation
171 |
172 | uses
173 | DB,
174 | google_oauth2,
175 | google_calendar,
176 | smtpsend,
177 | httpsend,
178 | synautil,
179 | Windows,
180 | comobj;
181 |
182 | {$R *.lfm}
183 |
184 | { TMainform }
185 |
186 | var
187 | client_id: string = '504681931309-gc0n3bqtr0dgp6se1d7ee6pcean7heho.apps.googleusercontent.com';
188 | client_secret: string = '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'; // only valid for my own test-user ( 2023-01-12 )
189 |
190 | var
191 | JDrive: Tgoogledrive;
192 |
193 | function Areyousure: boolean;
194 | var
195 | i, j, k: integer;
196 | var
197 | s1, s2: string;
198 | begin
199 | randomize;
200 | i := random(10);
201 | j := random(10);
202 | k := i + j;
203 | s1 := IntToStr(k);
204 | inputquery('Question', 'What is the result of ' + IntToStr(i) + ' + ' + IntToStr(j) + ' ?', s2);
205 | if s1 <> s2 then
206 | begin
207 | ShowMessage('Not correct !!!');
208 | Result := False;
209 | end
210 | else
211 | Result := True;
212 | end;
213 |
214 |
215 | procedure TMainform.AddToLog(Str: string);
216 | begin
217 | Memo1.Lines.Add(Str);
218 | end;
219 |
220 | procedure TMainform.CheckTokenFile;
221 | begin
222 |
223 | if FileExists('tokens.dat') then // already tokens
224 | begin
225 | CheckGroup1.Enabled := False;
226 | CheckGroup1.Caption := 'Access (scope) remove tokens.dat first to get new access';
227 | btGetAccess.Caption := 'Check access';
228 | end
229 | else
230 | begin
231 | CheckGroup1.Enabled := True;
232 | CheckGroup1.Caption := 'Access (scope)';
233 | btGetAccess.Caption := 'Get access';
234 | end;
235 |
236 | end;
237 |
238 | procedure TMainform.FormCreate(Sender: TObject);
239 | var
240 | Cfg: TJSONConfig;
241 | begin
242 |
243 | Memo1.Clear;
244 | Memo2.Clear;
245 | ListView1.Clear;
246 | Treeview1.Items.Clear;
247 |
248 | Cfg := TJSONConfig.Create(nil);
249 | try
250 | cfg.Filename:= 'client.json';
251 | client_id := cfg.GetValue('installed/client_id', client_id);
252 | client_secret := cfg.GetValue('installed/client_secret', client_secret);
253 | finally
254 | Cfg.Free;
255 | end;
256 |
257 | if Pos('504681931309', client_id) = 1 then // default client_id
258 | begin
259 | AddToLog('Using client_id from sourcecode (' + client_id + ')');
260 | AddToLog('You need to create your own project and download the client.json');
261 | AddToLog('See README.md for information');
262 | end
263 | else
264 | begin
265 | AddToLog('Using client_id from file client.json (' + client_id + ')');
266 | end;
267 |
268 | Jdrive := TGoogleDrive.Create(Self, client_id, client_secret);
269 | Jdrive.Progress := ProgressBar1;
270 | Jdrive.LogMemo := Memo1;
271 |
272 | Width := round(Screen.Width * 0.6);
273 | Height := round(Screen.Height * 0.9) - 100;
274 | Top := 100;
275 |
276 | edStart.Date := Now;
277 | edEnd.Date := Now;
278 |
279 | CheckGroup1.Checked[0] := True;
280 | CheckGroup1.Checked[1] := True;
281 | CheckGroup1.Checked[2] := True;
282 | CheckGroup1.CheckEnabled[0] := False;
283 | CheckGroup1.CheckEnabled[1] := False;
284 |
285 | PageControl1.ActivePageIndex := 0;
286 |
287 | CheckTokenFile;
288 |
289 | end;
290 |
291 | procedure TMainform.FormDestroy(Sender: TObject);
292 | begin
293 |
294 | Jdrive.Free;
295 |
296 | end;
297 |
298 | procedure TMainform.AfterShow(var Msg: TLMessage);
299 | begin
300 |
301 | //if FileExists('Pendingupload.txt') then
302 | //begin
303 | // PageControl1.ActivePage := TabSheet3;
304 | // PageControl5.ActivePage := TabSheet12;
305 | // btnUploadWithResume.Click;
306 | //end;
307 |
308 | end;
309 |
310 | procedure TMainform.FormShow(Sender: TObject);
311 | begin
312 | PostMessage(Self.Handle, WM_AFTER_SHOW, 0, 0);
313 | end;
314 |
315 |
316 | function assignTgdexport(mimetype: string): tgdexportarray;
317 | begin
318 | setlength(Result, 0);
319 | if mimeType='application/vnd.google-apps.document' then result := GoogleDocumentsExport;
320 | if mimeType='application/vnd.google-apps.drawing' then result := GoogleDrawingsExport;
321 | if mimeType='application/vnd.google-apps.spreadsheet' then result := GoogleSpreadsheetsExport;
322 | if mimeType='application/vnd.google-apps.presentation' then result := GooglePresentationsExport;
323 | end;
324 |
325 | procedure TMainform.ExporttoFile(Sender: TObject);
326 | var
327 | FileId, mimetype, filename: string;
328 | var
329 | exp: tgdExportArray;
330 | var
331 | fileextension, exportmt: string;
332 | var
333 | index: integer;
334 | begin
335 |
336 | index := Listview1.ItemIndex;
337 | if index < 0 then exit;
338 | if Jdrive.gOAuth2.EMail = '' then exit;
339 |
340 | FileId := JDrive.Files[index].fileid;
341 | mimeType := JDrive.Files[index].mimeType;
342 | FileName := JDrive.Files[index].Name;
343 |
344 | exp := assignTgdexport(mimetype);
345 | fileextension := exp[(Sender as tmenuitem).tag].FileExtension;
346 | exportmt := exp[(Sender as tmenuitem).tag].MimeType;
347 |
348 | JDrive.DownloadFile(fileid, filename + fileextension, '', exportmt);
349 | end;
350 |
351 | procedure TMainform.ListView1Click(Sender: TObject);
352 | var
353 | i: tmenuitem;
354 | var
355 | j, index: integer;
356 | var
357 | FileId, mimetype: string;
358 | var
359 | exp: tgdExportArray;
360 | begin
361 |
362 | index := Listview1.ItemIndex;
363 | if index < 0 then exit;
364 | if Jdrive.gOAuth2.EMail = '' then exit;
365 | FileId := JDrive.Files[index].fileid;
366 | mimeType := JDrive.Files[index].mimeType;
367 | popupmenu1.Items[0].Enabled := True;
368 | if Pos('application/vnd.google-apps', mimetype) > 0 then popupmenu1.Items[0].Enabled := False;
369 | popupmenu1.Items[1].Enabled := False;
370 |
371 | if FileId <> '' then
372 | begin
373 | if mimeType = 'application/vnd.google-apps.folder' then exit;
374 | end;
375 |
376 | exp := assignTgdexport(mimetype);
377 | if length(exp) = 0 then exit;
378 |
379 | with popupmenu1.Items[1] do
380 | begin
381 | Clear;
382 | for j := 0 to length(exp) - 1 do
383 | begin
384 | i := Tmenuitem.Create(popupmenu1.Items[1]);
385 | i.Caption := 'Export to ' + exp[j].Description;
386 | i.Tag := j;
387 | i.OnClick := @exporttofile;
388 | popupmenu1.Items[1].Add(i);
389 | end;
390 | end;
391 |
392 | popupmenu1.Items[1].Enabled := True;
393 |
394 | end;
395 |
396 |
397 |
398 |
399 | procedure TMainform.StringGrid1DblClick(Sender: TObject);
400 | var
401 | Filename: string;
402 | FileId: string;
403 | A: TGFileRevisions;
404 | prop: TCustomproperties;
405 | Rev: integer;
406 | begin
407 |
408 | if Jdrive.gOAuth2.EMail = '' then exit;
409 |
410 | StringGrid4.Options := StringGrid4.Options + [goRowSelect];
411 | Stringgrid4.colcount := 9;
412 | Stringgrid4.rowcount := 1;
413 | StringGrid4.Cells[1, 0] := 'Title';
414 | StringGrid4.Cells[2, 0] := 'Created';
415 | StringGrid4.Cells[3, 0] := 'Modified';
416 | StringGrid4.Cells[4, 0] := 'Filename';
417 | StringGrid4.Cells[5, 0] := 'Size';
418 | StringGrid4.Cells[6, 0] := 'FileId';
419 | StringGrid4.Cells[7, 0] := 'MimeType';
420 | StringGrid4.Cells[8, 0] := 'RevisionId';
421 |
422 |
423 | with TStringGrid(Sender) do
424 | begin
425 | FileId := cells[6, Row];
426 | Filename := cells[4, Row];
427 | if Filename = '' then Filename := cells[1, Row]; // title
428 | end;
429 |
430 | Filename := Extractfilepath(ParamStr(0)) + Filename;
431 | // check for valid filename
432 |
433 | try
434 | with Jdrive do
435 | begin
436 | ClearAllCustomProperties;
437 | AddCustomProperty(CustomBodyProperties, 'name', 'Filename Test', AsString);
438 | AddCustomProperty(CustomBodyProperties, 'originalFilename', 'Filename Test', AsString);
439 | AddCustomProperty(CustomBodyProperties, 'trashed', 'false');
440 | AddCustomProperty(CustomBodyProperties, 'description', 'Desciption test', AsString);
441 | AddCustomProperty(CustomBodyProperties, 'starred', 'true');
442 | AddCustomProperty(CustomQueryProperties, 'keepRevisionForever', 'true');
443 | SetFileProperties(Fileid);
444 | end;
445 | except
446 | end;
447 |
448 | try
449 | // JDrive.DownloadFile(FileId, Filename);
450 | A := JDrive.GetRevisions(FileId);
451 | stringgrid4.rowcount := Length(A) + 1;
452 | Memo1.Lines.add(IntToStr(length(A)) + ' revisions found');
453 | if Length(A) > 0 then
454 | for Rev := 0 to Length(A) - 1 do
455 | begin
456 | ;
457 | StringGrid4.Cells[8, Rev + 1] := A[Rev].revisionid;
458 | StringGrid4.Cells[6, Rev + 1] := A[Rev].id;
459 | StringGrid4.Cells[4, Rev + 1] := A[Rev].originalFileName;
460 | StringGrid4.Cells[7, Rev + 1] := A[Rev].mimetype;
461 | StringGrid4.Cells[3, Rev + 1] := A[Rev].modifiedTime;
462 | Memo1.Lines.Add(A[Rev].revisionid + ' - ' + A[Rev].mimetype + ' - ' + A[Rev].modifiedTime);
463 | end
464 | else
465 | Memo1.Lines.Add('no revisions');
466 | except
467 | ShowMessage('Could not save ' + Filename);
468 | end;
469 | end;
470 |
471 | procedure TMainform.StringGrid3KeyDown(Sender: TObject; var Key: word; Shift: TShiftState);
472 | var
473 | fileid, revisionid: string;
474 | begin
475 |
476 | if Jdrive.gOAuth2.EMail = '' then exit;
477 |
478 | if key = VK_DELETE then
479 | with TStringGrid(Sender) do
480 | begin
481 | FileId := cells[6, Row];
482 | Revisionid := cells[8, Row];
483 |
484 | end;
485 | end;
486 |
487 | procedure TMainform.StringGrid4DblClick(Sender: TObject);
488 | var
489 | fileid, revisionid, filename: string;
490 | begin
491 | with TStringGrid(Sender) do
492 | begin
493 | filename := cells[4, Row];
494 | FileId := cells[6, Row];
495 | revisionid := cells[8, Row];
496 | end;
497 | Jdrive.DownloadFile(fileid, filename, revisionid);
498 | end;
499 |
500 | procedure TMainform.btGetAccessClick(Sender: TObject);
501 | var
502 | gOAuth2: TGoogleOAuth2;
503 | Scopes: GoogleScopeSet;
504 | begin
505 | // Onetime authentication
506 | // Save tokens to tokens.dat
507 | gOAuth2 := TGoogleOAuth2.Create(client_id, client_secret);
508 | try
509 |
510 | Scopes := [];
511 | if CheckGroup1.Checked[2] then Include(Scopes, goMail);
512 | if CheckGroup1.Checked[3] then Include(Scopes, goContacts);
513 | if CheckGroup1.Checked[4] then Include(Scopes, goCalendar);
514 | if CheckGroup1.Checked[5] then Include(Scopes, goDrive);
515 |
516 | gOAuth2.LogMemo := Memo1;
517 | gOAuth2.DebugMemo := Memo2;
518 | gOAuth2.GetAccess(Scopes, True); // <- get from file
519 |
520 | if gOAuth2.EMail <> '' then
521 | begin
522 | edSender.Text := format('%s <%s>', [gOAuth2.FullName, gOAuth2.EMail]);
523 | if (edRecipient.Text = '') or (edRecipient.Text = 'recipient@valid_domain.com') then
524 | edRecipient.Text := format('%s', [gOAuth2.EMail]);
525 | end;
526 |
527 | CheckTokenFile;
528 |
529 | finally
530 | gOAuth2.Free;
531 | end;
532 |
533 | end;
534 |
535 | procedure TMainform.btGetContactsClick(Sender: TObject);
536 | begin
537 | // not implemented yet
538 | end;
539 |
540 |
541 | procedure TMainform.btRemoveTokensClick(Sender: TObject);
542 | begin
543 | if not FileExists('tokens.dat') then
544 | begin
545 | AddToLog('tokens.dat does not exist');
546 | exit;
547 | end;
548 |
549 | Deletefile('tokens.dat');
550 |
551 | if not FileExists('tokens.dat') then
552 | AddToLog('tokens.dat deleted')
553 | else
554 | AddToLog('error while removing tokens.dat');
555 |
556 | CheckTokenFile;
557 |
558 | end;
559 |
560 | // -----------------------------------------------------
561 | // Little hack for TSMTPSend to give the command XOAUTH2
562 | // -----------------------------------------------------
563 |
564 | type
565 | TmySMTPSend = class helper for TSMTPSend
566 | public
567 | function DoXOAuth2(const Value: string): boolean;
568 | function ChallengeError(): string;
569 | end;
570 |
571 |
572 | function TmySMTPSend.DoXOAuth2(const Value: string): boolean;
573 | var
574 | x: integer;
575 | s: string;
576 | begin
577 | Sock.SendString('AUTH XOAUTH2 ' + Value + CRLF);
578 | repeat
579 | s := Sock.RecvString(FTimeout);
580 | if Sock.LastError <> 0 then
581 | Break;
582 | until Pos('-', s) <> 4;
583 | x := StrToIntDef(Copy(s, 1, 3), 0);
584 | Result := (x = 235);
585 | end;
586 |
587 | function TmySMTPSend.ChallengeError(): string;
588 | var
589 | s: string;
590 | begin
591 | Result := '';
592 | Sock.SendString('' + CRLF);
593 | repeat
594 | s := Sock.RecvString(FTimeout);
595 | if Sock.LastError <> 0 then
596 | Break;
597 | if Result <> '' then
598 | Result := Result + CRLF;
599 | Result := Result + s;
600 | until Pos('-', s) <> 4;
601 | end;
602 |
603 | // -----------------------------------------------------
604 | // -----------------------------------------------------
605 |
606 | procedure TMainform.btSendMailClick(Sender: TObject);
607 | var
608 | gOAuth2: TGoogleOAuth2;
609 | smtp: TSMTPSend;
610 | msg_lines: TStringList;
611 | begin
612 | if (edRecipient.Text = '') or (edRecipient.Text = 'recipient@valid_domain.com') then
613 | begin
614 | Memo1.Lines.Add('Please change the recipient');
615 | exit;
616 | end;
617 |
618 | if not FileExists('tokens.dat') then
619 | begin
620 | // first get all access clicked on Groupbox
621 | btGetAccess.Click;
622 | end;
623 |
624 | gOAuth2 := TGoogleOAuth2.Create(client_id, client_secret);
625 | smtp := TSMTPSend.Create;
626 | msg_lines := TStringList.Create;
627 | try
628 | btSendMail.Enabled := False;
629 |
630 | // first get oauthToken
631 | gOAuth2.LogMemo := Memo1;
632 | gOAuth2.DebugMemo := Memo2;
633 | gOAuth2.GetAccess([], True); // <- get from file
634 | // no need for scope because we should already have access
635 | // via the btGetAccess for all the scopes in Groupbox
636 | if gOAuth2.EMail = '' then
637 | exit;
638 |
639 | CheckTokenFile;
640 |
641 | edSender.Text := format('%s <%s>', [gOAuth2.FullName, gOAuth2.EMail]);
642 |
643 | msg_lines.Add('From: ' + edSender.Text);
644 | msg_lines.Add('To: ' + edRecipient.Text);
645 | msg_lines.Add('Subject: ' + edSubject.Text);
646 | msg_lines.Add('');
647 | msg_lines.Add(edBody.Text);
648 |
649 | smtp.TargetHost := 'smtp.gmail.com';
650 | smtp.TargetPort := '587';
651 |
652 | AddToLog('SMTP Login');
653 | if not smtp.Login() then
654 | begin
655 | AddToLog('SMTP ERROR: Login:' + smtp.EnhCodeString);
656 | exit;
657 | end;
658 | if not smtp.StartTLS() then
659 | begin
660 | AddToLog('SMTP ERROR: StartTLS:' + smtp.EnhCodeString);
661 | exit;
662 | end;
663 |
664 | AddToLog('XOAUTH2');
665 | if not smtp.DoXOAuth2(gOAuth2.GetXOAuth2Base64) then
666 | begin
667 | AddToLog('XOAUTH2 ERROR: ' + CRLF + smtp.ChallengeError());
668 | exit;
669 | end;
670 |
671 | AddToLog('SMTP Mail');
672 | if not smtp.MailFrom(gOAuth2.EMail, Length(gOAuth2.EMail)) then
673 | begin
674 | AddToLog('SMTP ERROR: MailFrom:' + smtp.EnhCodeString);
675 | exit;
676 | end;
677 | if not smtp.MailTo(edRecipient.Text) then
678 | begin
679 | AddToLog('SMTP ERROR: MailTo:' + smtp.EnhCodeString);
680 | exit;
681 | end;
682 | if not smtp.MailData(msg_lines) then
683 | begin
684 | AddToLog('SMTP ERROR: MailData:' + smtp.EnhCodeString);
685 | exit;
686 | end;
687 |
688 | AddToLog('SMTP Logout');
689 | if not smtp.Logout() then
690 | begin
691 | AddToLog('SMTP ERROR: Logout:' + smtp.EnhCodeString);
692 | exit;
693 | end;
694 |
695 | AddToLog('OK !');
696 |
697 | finally
698 | gOAuth2.Free;
699 | smtp.Free;
700 | msg_lines.Free;
701 | btSendMail.Enabled := True;
702 | end;
703 |
704 | end;
705 |
706 | procedure TMainform.btClearLogClick(Sender: TObject);
707 | begin
708 | Memo1.Clear;
709 | end;
710 |
711 | // Bubblesort Integer
712 |
713 | const
714 | // Define the Separator
715 | TheSeparator = #254;
716 |
717 | procedure BubbleSort_int(Items: TStrings);
718 | var
719 | done: boolean;
720 | ThePosition, ThePosition2, i, n: integer;
721 | TempString, TempString2, MyString, Mystring2, Dummy: string;
722 | begin
723 | n := Items.Count;
724 | repeat
725 | done := True;
726 | for i := 0 to n - 2 do
727 | begin
728 | MyString := items[i];
729 | MyString2 := items[i + 1];
730 | ThePosition := Pos(TheSeparator, MyString);
731 | ThePosition2 := Pos(TheSeparator, MyString2);
732 | TempString := Copy(MyString, 1, ThePosition);
733 | TempString2 := Copy(MyString2, 1, ThePosition2);
734 | if AnsiCompareText(TempString, TempString2) < 0 then
735 | begin
736 | Dummy := Items[i];
737 | Items[i] := Items[i + 1];
738 | Items[i + 1] := Dummy;
739 | done := False;
740 | end;
741 | end;
742 | until done;
743 | end;
744 |
745 | procedure SortStringGrid(var GenStrGrid: TStringGrid; ThatCol: integer);
746 | var
747 | CountItem, I, J, K, ThePosition: integer;
748 | MyList: TStringList;
749 | MyString, TempString: string;
750 | begin
751 | // Give the number of rows in the StringGrid
752 | CountItem := GenStrGrid.RowCount;
753 | //Create the List
754 | MyList := TStringList.Create;
755 | MyList.Sorted := False;
756 | try
757 | begin
758 | for I := 1 to (CountItem - 1) do
759 | MyList.Add(GenStrGrid.Rows[I].Strings[ThatCol] + TheSeparator +
760 | GenStrGrid.Rows[I].Text);
761 | //Sort the List
762 | //Mylist.Sort; INSTEAD
763 | BubbleSort_int(Mylist);
764 |
765 | for K := 1 to Mylist.Count do
766 | begin
767 | //Take the String of the line (K – 1)
768 | MyString := MyList.Strings[(K - 1)];
769 | //Find the position of the Separator in the String
770 | ThePosition := Pos(TheSeparator, MyString);
771 | TempString := '';
772 | {Eliminate the Text of the column on which we have sorted the StringGrid}
773 | TempString := Copy(MyString, (ThePosition + 1), Length(MyString));
774 | MyList.Strings[(K - 1)] := '';
775 | MyList.Strings[(K - 1)] := TempString;
776 | end;
777 |
778 | // Refill the StringGrid
779 | for J := 1 to (CountItem - 1) do
780 | GenStrGrid.Rows[J].Text := MyList.Strings[(J - 1)];
781 | end;
782 | finally
783 | //Free the List
784 | MyList.Free;
785 | end;
786 | end;
787 |
788 |
789 | procedure TMainform.btGetAppointmentsClick(Sender: TObject);
790 | var
791 | Response: TStringList;
792 | Q: integer;
793 | StartDt: string;
794 | EndDt: string;
795 | nwWidth: integer;
796 | ds: TGoogleCalendar;
797 | begin
798 |
799 | Response := TStringList.Create;
800 | ds := TGoogleCalendar.Create(Self, client_id, client_secret);
801 | try
802 | btGetAppointments.Enabled := False;
803 |
804 | ds.gOAuth2.LogMemo := Memo1;
805 | ds.gOAuth2.DebugMemo := Memo2;
806 | ds.gOAuth2.GetAccess([goCalendar], True);
807 |
808 | CheckTokenFile;
809 |
810 | if ds.gOAuth2.EMail = '' then
811 | exit;
812 |
813 | ds.Open;
814 | ds.Populate();
815 |
816 | StringGrid1.Options := StringGrid1.Options + [goRowSelect];
817 | StringGrid1.ColCount := 5;
818 | StringGrid1.RowCount := 2;
819 | StringGrid1.Cells[1, 0] := 'Start';
820 | StringGrid1.Cells[2, 0] := 'Eind';
821 | StringGrid1.Cells[3, 0] := 'Afspraak';
822 | StringGrid1.Cells[4, 0] := 'Link';
823 |
824 | AddToLog('Busy filling grid');
825 | SendMessage(StringGrid1.Handle, WM_SETREDRAW, 0, 0);
826 | try
827 | ds.First;
828 | while not ds.EOF do
829 | begin
830 |
831 | with StringGrid1 do
832 | begin
833 | Cells[1, StringGrid1.RowCount - 1] := ds.FieldByName('start').AsString;
834 | Cells[2, StringGrid1.RowCount - 1] := ds.FieldByName('end').AsString;
835 | Cells[3, StringGrid1.RowCount - 1] := ds.FieldByName('summary').AsString;
836 | Cells[4, StringGrid1.RowCount - 1] := ds.FieldByName('htmllink').AsString;
837 | end;
838 |
839 | for Q := 1 to 4 do
840 | begin
841 | nwWidth := StringGrid1.Canvas.TextWidth(
842 | StringGrid1.Cells[Q, StringGrid1.RowCount - 1]);
843 | if nwWidth > StringGrid1.ColWidths[Q] then
844 | StringGrid1.ColWidths[Q] := nwWidth + 20;
845 | end;
846 | Application.ProcessMessages;
847 | StringGrid1.RowCount := StringGrid1.RowCount + 1;
848 |
849 | ds.Next;
850 | end;
851 |
852 | AddToLog('Sorting');
853 | SortStringGrid(StringGrid1, 1);
854 |
855 | StringGrid1.ColWidths[0] := 10;
856 | StringGrid1.ColWidths[4] := 0; // <- also not -1
857 | // StringGrid1.Columns[4].Visible := false; // <- why does this give an error ?
858 | while (StringGrid1.RowCount > 2) and (StringGrid1.Cells[3, 1] = '') do
859 | StringGrid1.DeleteRow(1);
860 |
861 | AddToLog('Done filling grid');
862 |
863 | finally
864 | SendMessage(StringGrid1.Handle, WM_SETREDRAW, 1, 0);
865 | StringGrid1.Repaint;
866 | StringGrid1.SetFocus;
867 | end;
868 |
869 | finally
870 | Response.Free;
871 | ds.Free;
872 | btGetAppointments.Enabled := True;
873 | end;
874 |
875 | end;
876 |
877 |
878 | procedure TMainform.Button5Click(Sender: TObject);
879 | var
880 | gOAuth2: TGoogleOAuth2;
881 | HTTP: THTTPSend;
882 | URL: string;
883 | json: TJSONObject;
884 | dt_start, dt_end: TJSONObject;
885 | begin
886 |
887 | gOAuth2 := TGoogleOAuth2.Create(client_id, client_secret);
888 | try
889 | gOAuth2.LogMemo := Memo1;
890 | gOAuth2.DebugMemo := Memo2;
891 | gOAuth2.GetAccess([goCalendar], True);
892 |
893 | CheckTokenFile;
894 |
895 | if gOAuth2.EMail = '' then exit;
896 |
897 | HTTP := THTTPSend.Create;
898 | try
899 |
900 | json := TJSONObject.Create;
901 | dt_start := TJSONObject.Create;
902 | dt_end := TJSONObject.Create;
903 | try
904 | json.Add('summary', edTitle.Text);
905 | json.Add('location', edLocation.Text);
906 | json.Add('description', edDescription.Text);
907 | dt_start.Add('dateTime', FormatDateTime('yyyy-mm-dd', edStart.Date) + 'T' + FormatDateTime('hh:nn:ss', Now));
908 | dt_start.Add('timeZone', 'Europe/Amsterdam');
909 | dt_end.Add('dateTime', FormatDateTime('yyyy-mm-dd', edStart.Date) + 'T' + FormatDateTime('hh:nn:ss', Now));
910 | dt_end.Add('timeZone', 'Europe/Amsterdam');
911 | json.Add('start', dt_start);
912 | json.Add('end', dt_end);
913 | WriteStrToStream(HTTP.Document, ansistring(json.AsJSON));
914 | finally
915 | json.Free;
916 | // dt_start.Free; nope, added to json
917 | // dt_end.Free; nope, added to json
918 | end;
919 |
920 | URL := 'https://www.googleapis.com/calendar/v3/calendars/' + gOAuth2.EMail + '/events';
921 | HTTP.Headers.Add('Authorization: Bearer ' + gOAuth2.Access_token);
922 | HTTP.MimeType := 'application/json; charset=UTF-8';
923 | if HTTP.HTTPMethod('POST', URL) then
924 | begin
925 | if HTTP.ResultCode = 200 then
926 | Memo1.Lines.Add('event inserted')
927 | else
928 | Memo1.Lines.Add('error inserting');
929 | Memo2.Lines.LoadFromStream(HTTP.Document);
930 | end
931 | else
932 | begin
933 | Memo1.Lines.Add('error');
934 | Memo1.Lines.Add(HTTP.Headers.Text);
935 | end;
936 | finally
937 | HTTP.Free;
938 | end;
939 |
940 | finally
941 | gOAuth2.Free;
942 | end;
943 | end;
944 |
945 | procedure TMainform.Button6Click(Sender: TObject);
946 | begin
947 |
948 | Jdrive.cancelcurrent := True;
949 | end;
950 |
951 | procedure TMainform.Button7Click(Sender: TObject);
952 | begin
953 |
954 | end;
955 |
956 | procedure TMainform.ckHideFoldersClick(Sender: TObject);
957 | begin
958 | FillDriveGrid_old;
959 | end;
960 |
961 | procedure TMainform.FillDriveGrid_old;
962 | var
963 | Q: integer;
964 | nwWidth: integer;
965 | begin
966 |
967 | StringGrid3.RowCount := 2;
968 | AddToLog('Busy filling grid');
969 | SendMessage(StringGrid3.Handle, WM_SETREDRAW, 0, 0);
970 | try
971 | Jdrive.First;
972 | while not Jdrive.EOF do
973 | begin
974 | if not ckHideFolders.Checked or not Jdrive.FieldByName('IsFolder').AsBoolean then
975 | begin
976 | with StringGrid3 do
977 | begin
978 | Cells[1, StringGrid3.RowCount - 1] := Jdrive.FieldByName('title').AsString;
979 | Cells[2, StringGrid3.RowCount - 1] := Jdrive.FieldByName('created').AsString;
980 | Cells[3, StringGrid3.RowCount - 1] := Jdrive.FieldByName('modified').AsString;
981 | Cells[4, StringGrid3.RowCount - 1] := Jdrive.FieldByName('filename').AsString;
982 | Cells[5, StringGrid3.RowCount - 1] := Jdrive.FieldByName('filesize').AsString;
983 | Cells[6, StringGrid3.RowCount - 1] := Jdrive.FieldByName('fileId').AsString;
984 | Cells[7, StringGrid3.RowCount - 1] := Jdrive.FieldByName('mimeType').AsString;
985 | if Jdrive.FieldByName('mimeType').AsString = 'application/vnd.google-apps.folder' then
986 | Cells[7, StringGrid3.RowCount - 1] := '
';
987 | end;
988 |
989 | StringGrid3.RowCount := StringGrid3.RowCount + 1;
990 |
991 | end;
992 |
993 | Jdrive.Next;
994 | end;
995 |
996 | if (StringGrid3.RowCount > 2) then
997 | StringGrid3.RowCount := StringGrid3.RowCount - 1;
998 |
999 | StringGrid3.AutoSizeColumns;
1000 | StringGrid3.ColWidths[0] := 10;
1001 | StringGrid3.ColWidths[6] := 1;
1002 |
1003 | AddToLog('Done filling grid');
1004 |
1005 | finally
1006 | SendMessage(StringGrid3.Handle, WM_SETREDRAW, 1, 0);
1007 | StringGrid3.Repaint;
1008 | StringGrid3.SetFocus;
1009 | end;
1010 |
1011 | end;
1012 |
1013 | procedure TMainform.btGetFileListClick(Sender: TObject);
1014 | var
1015 | Response: TStringList;
1016 | StartDt: string;
1017 | EndDt: string;
1018 | begin
1019 |
1020 | Response := TStringList.Create;
1021 | try
1022 | btGetFileList.Enabled := False;
1023 |
1024 | JDrive.gOAuth2.LogMemo := Memo1;
1025 | Jdrive.gOAuth2.DebugMemo := Memo2;
1026 | Jdrive.gOAuth2.GetAccess([goDrive], True);
1027 |
1028 | CheckTokenFile;
1029 |
1030 | if Jdrive.gOAuth2.EMail = '' then
1031 | exit;
1032 |
1033 | Jdrive.Open;
1034 |
1035 | // JDrive.CreateFolder('bbbb');
1036 |
1037 | Jdrive.Populate();
1038 |
1039 | StringGrid3.Options := StringGrid3.Options + [goRowSelect];
1040 | StringGrid3.ColCount := 8;
1041 |
1042 | StringGrid3.RowCount := 2;
1043 | StringGrid3.Cells[1, 0] := 'Title';
1044 | StringGrid3.Cells[2, 0] := 'Created';
1045 | StringGrid3.Cells[3, 0] := 'Modified';
1046 | StringGrid3.Cells[4, 0] := 'Filename';
1047 | StringGrid3.Cells[5, 0] := 'Size';
1048 | StringGrid3.Cells[6, 0] := 'FileId';
1049 | StringGrid3.Cells[7, 0] := 'MimeType';
1050 | StringGrid3.AutoFillColumns := False;
1051 |
1052 | FillDriveGrid_old;
1053 |
1054 | finally
1055 | Response.Free;
1056 | btGetFileList.Enabled := True;
1057 | end;
1058 |
1059 | end;
1060 |
1061 | function DownloadHTTPStream(cURL: string; aStream: TStream): boolean;
1062 | var
1063 | HTTP: THTTPSend;
1064 | begin
1065 | Result := False;
1066 | HTTP := THTTPSend.Create;
1067 | try
1068 | { HTTPGetResult := } HTTP.HTTPMethod('GET', cURL);
1069 | if (HTTP.ResultCode >= 100) and (HTTP.ResultCode <= 299) then
1070 | begin
1071 | HTTP.Document.SaveToStream(aStream);
1072 | aStream.Position := 0;
1073 | Result := True;
1074 | end;
1075 | finally
1076 | HTTP.Free;
1077 | end;
1078 | end;
1079 |
1080 | procedure LoadImageFromWeb(const Image: TImage; Url: string);
1081 | var
1082 | mems: TMemoryStream;
1083 | R: TRect;
1084 | begin
1085 | if Url <> '' then
1086 | begin
1087 | mems := TMemoryStream.Create;
1088 | try
1089 | if DownloadHTTPStream(Url, mems) then
1090 | begin
1091 | Image.Picture.LoadFromStream(mems);
1092 | end;
1093 | finally
1094 | mems.Free;
1095 | end;
1096 | end;
1097 | end;
1098 |
1099 | procedure TMainform.TreeView1SelectionChanged(Sender: TObject);
1100 | begin
1101 | end;
1102 |
1103 | procedure TMainform.TreeView1Click(Sender: TObject);
1104 | begin
1105 | //FillDriveView;
1106 | end;
1107 |
1108 |
1109 | procedure TMainform.FillDriveView2;
1110 | var
1111 | Q: integer;
1112 | nwWidth: integer;
1113 | TreeNode: TTreeNode;
1114 | ListItem: TListItem;
1115 | Img: TImage;
1116 | IconLink: string;
1117 | ImgLinkList: TStringList;
1118 | MapId: string;
1119 | z: integer;
1120 | begin
1121 |
1122 | //MapId := '';
1123 | //if (Treeview1.Selected <> nil) and (Treeview1.Selected.Data <> nil) then
1124 | //begin
1125 | // JDrive.GotoBookmark(Treeview1.Selected.Data);
1126 | // MapId := Jdrive.FieldByName('FileId').AsString;
1127 | // StatusBar1.SimpleText := MapId;
1128 | //end;
1129 | listview1.BeginUpdate;
1130 | ListView1.Clear;
1131 | TreeView1.Images := ImageList1;
1132 | // ListView1.ViewStyle:=vsIcon;
1133 | ListView1.MultiSelect := True;
1134 |
1135 | ListView1.LargeImages := nil;
1136 | ListView1.SmallImages := nil;
1137 | ImageList1.Clear;
1138 | ListView1.LargeImages := ImageList1;
1139 | ListView1.SmallImages := ImageList1;
1140 |
1141 | ImgLinkList := TStringList.Create;
1142 |
1143 |
1144 | ProgressBar2.Max := length(JDrive.Files) - 1;
1145 |
1146 | AddToLog('Busy filling grid');
1147 | try
1148 | for z := 0 to length(JDrive.Files) - 1 do
1149 | begin
1150 | application.ProcessMessages;
1151 | ProgressBar2.Position := z;
1152 | begin
1153 | ListItem := ListView1.Items.Add;
1154 |
1155 | (*
1156 | Load icon 90x90 to a stringlist
1157 | Convert them to 16x16
1158 | and load from internet in a thread
1159 | *)
1160 | IconLink := Jdrive.Files[z].iconLink;
1161 | if (IconLink <> '') then
1162 | begin
1163 | ListItem.ImageIndex := ImgLinkList.IndexOf(IconLink);
1164 | if ListItem.ImageIndex = -1 then
1165 | begin
1166 | Img := TImage.Create(nil);
1167 | try
1168 | LoadImageFromWeb(Img, IconLink);
1169 | ListItem.ImageIndex := ImageList1.Add(Img.Picture.Bitmap, nil);
1170 | ImgLinkList.Add(IconLink);
1171 | finally
1172 | Img.Free;
1173 | end;
1174 | end;
1175 | end;
1176 |
1177 | ListItem.Caption := Jdrive.Files[z].Name;
1178 | ListItem.SubItems.Add(Jdrive.Files[z].modifiedTime);
1179 | ListItem.SubItems.Add(Jdrive.Files[z].size);
1180 | ListItem.SubItems.Add(Jdrive.Files[z].mimeType);
1181 | ListItem.SubItems.Add(Jdrive.Files[z].originalFilename);
1182 | ListItem.SubItems.Add(Jdrive.Files[z].fileid);
1183 |
1184 | end;
1185 | end;
1186 |
1187 | AddToLog('Done filling grid');
1188 |
1189 |
1190 | finally
1191 | listview1.EndUpdate;
1192 | ProgressBar2.Position := 0;
1193 | ImgLinkList.Free;
1194 |
1195 | end;
1196 | end;
1197 |
1198 |
1199 | procedure TMainform.FillDriveView;
1200 | var
1201 | Q: integer;
1202 | nwWidth: integer;
1203 | TreeNode: TTreeNode;
1204 | ListItem: TListItem;
1205 | Img: TImage;
1206 | IconLink: string;
1207 | ImgLinkList: TStringList;
1208 | MapId: string;
1209 | BookMark: TBookmark;
1210 | begin
1211 |
1212 | //MapId := '';
1213 | //if (Treeview1.Selected <> nil) and (Treeview1.Selected.Data <> nil) then
1214 | //begin
1215 | // JDrive.GotoBookmark(Treeview1.Selected.Data);
1216 | // MapId := Jdrive.FieldByName('FileId').AsString;
1217 | // StatusBar1.SimpleText := MapId;
1218 | //end;
1219 |
1220 | ListView1.Clear;
1221 | Treeview1.Items.Clear;
1222 | Application.ProcessMessages; // update views
1223 |
1224 |
1225 | TreeView1.Images := ImageList1;
1226 |
1227 | // ListView1.ViewStyle:=vsIcon;
1228 | ListView1.MultiSelect := True;
1229 |
1230 | ListView1.LargeImages := nil;
1231 | ListView1.SmallImages := nil;
1232 | ImageList1.Clear;
1233 | ListView1.LargeImages := ImageList1;
1234 | ListView1.SmallImages := ImageList1;
1235 |
1236 | ImgLinkList := TStringList.Create;
1237 |
1238 | ProgressBar2.Max := JDrive.RecordCount;
1239 |
1240 | AddToLog('Busy filling grid');
1241 | try
1242 | Jdrive.First;
1243 | while not Jdrive.EOF do
1244 | begin
1245 |
1246 | ProgressBar2.Position := JDrive.RecNo;
1247 |
1248 | if Jdrive.FieldByName('IsFolder').AsBoolean then
1249 | begin
1250 | if TreeView1.Items.Count = 0 then
1251 | begin
1252 | Treeview1.Items.Add(nil, 'Google Drive');
1253 | end;
1254 | BookMark := JDrive.Bookmark;
1255 | TreeNode := Treeview1.Items.AddChildObject(
1256 | Treeview1.Items.GetFirstNode, Jdrive.FieldByName('title').AsString, Pointer(Bookmark));
1257 |
1258 | IconLink := Jdrive.FieldByName('iconLink').AsString;
1259 | if False and (IconLink <> '') then
1260 | begin
1261 | TreeNode.ImageIndex := ImgLinkList.IndexOf(IconLink);
1262 | if TreeNode.ImageIndex = -1 then
1263 | begin
1264 | Img := TImage.Create(nil);
1265 | try
1266 | LoadImageFromWeb(Img, IconLink);
1267 | TreeNode.ImageIndex := ImageList1.Add(Img.Picture.Bitmap, nil);
1268 | ImgLinkList.Add(IconLink);
1269 | finally
1270 | Img.Free;
1271 | end;
1272 | end;
1273 | end;
1274 |
1275 | end
1276 | else
1277 | begin
1278 | ListItem := ListView1.Items.Add;
1279 |
1280 | (*
1281 | Load icon 90x90 to a stringlist
1282 | Convert them to 16x16
1283 | and load from internet in a thread
1284 | *)
1285 | IconLink := Jdrive.FieldByName('iconLink').AsString;
1286 | if True and (IconLink <> '') then
1287 | begin
1288 | ListItem.ImageIndex := ImgLinkList.IndexOf(IconLink);
1289 | if ListItem.ImageIndex = -1 then
1290 | begin
1291 | Img := TImage.Create(nil);
1292 | try
1293 | LoadImageFromWeb(Img, IconLink);
1294 | ListItem.ImageIndex := ImageList1.Add(Img.Picture.Bitmap, nil);
1295 | ImgLinkList.Add(IconLink);
1296 | finally
1297 | Img.Free;
1298 | end;
1299 | end;
1300 | end;
1301 |
1302 | ListItem.Caption := Jdrive.FieldByName('title').AsString;
1303 | ListItem.SubItems.Add(Jdrive.FieldByName('modified').AsString);
1304 | ListItem.SubItems.Add(Jdrive.FieldByName('filesize').AsString);
1305 | ListItem.SubItems.Add(Jdrive.FieldByName('mimeType').AsString);
1306 | ListItem.SubItems.Add(Jdrive.FieldByName('filename').AsString);
1307 | ListItem.SubItems.Add(Jdrive.FieldByName('fileId').AsString);
1308 |
1309 | end;
1310 |
1311 | Jdrive.Next;
1312 | end;
1313 |
1314 | AddToLog('Done filling grid');
1315 | TreeView1.FullExpand;
1316 |
1317 | finally
1318 | ProgressBar2.Position := 0;
1319 | ImgLinkList.Free;
1320 | end;
1321 | end;
1322 |
1323 | procedure TMainform.Button1Click(Sender: TObject);
1324 | var
1325 | Q: integer;
1326 | nwWidth: integer;
1327 | TreeNode: TTreeNode;
1328 | ListItem: TListItem;
1329 | Img: TImage;
1330 | IconLink: string;
1331 | ImgLinkList: TStringList;
1332 | begin
1333 |
1334 | JDrive.gOAuth2.LogMemo := Memo1;
1335 | Jdrive.gOAuth2.DebugMemo := Memo2;
1336 | Jdrive.gOAuth2.GetAccess([goDrive], True);
1337 |
1338 | CheckTokenFile;
1339 |
1340 | if Jdrive.gOAuth2.EMail = '' then
1341 | exit;
1342 |
1343 | Jdrive.Open;
1344 | if not listmthd.Checked then
1345 | begin
1346 | Jdrive.Populate();
1347 | FillDriveView;
1348 | end
1349 | else
1350 | begin
1351 | JDrive.ListFiles(JDrive.Files, [showpreviousfolder, listparents], 'root', 'name,originalFilename,mimeType,id,size,modifiedTime,iconLink,parents,md5Checksum');
1352 | FillDriveView2;
1353 | end;
1354 |
1355 | end;
1356 |
1357 | procedure TMainform.ListView1DblClick(Sender: TObject);
1358 | var
1359 | ListItem: TListItem;
1360 | FileId, mimeType: string;
1361 | A: TGFileRevisions;
1362 | Rev: integer;
1363 | begin
1364 | Jdrive.Progress := ProgressBar1;
1365 |
1366 | if Jdrive.gOAuth2.EMail = '' then exit;
1367 |
1368 | ListView2.Clear;
1369 | ListView2.LargeImages := ImageList1;
1370 | ListView2.SmallImages := ImageList1;
1371 |
1372 | FileId := '';
1373 | if (ListView1.Selected.SubItems.Count > 4) then
1374 | FileId := ListView1.Selected.SubItems.Strings[4];
1375 | mimeType := ListView1.Selected.SubItems.Strings[2];
1376 |
1377 | if FileId <> '' then
1378 | begin
1379 | if mimeType = 'application/vnd.google-apps.folder' then
1380 | begin
1381 | Jdrive.ListFiles(JDrive.Files, [showpreviousfolder, listparents], FileId, 'name,originalFilename,mimeType,id,size,modifiedTime,iconLink,parents,md5Checksum');
1382 | FillDriveView2;
1383 | exit;
1384 | end
1385 | else
1386 | begin
1387 | JDrive.DownloadFile(fileid, 'test.pdf', '', 'application/pdf');
1388 | A := JDrive.GetRevisions(FileId);
1389 | Memo1.Lines.add(IntToStr(length(A)) + ' revisions found');
1390 | if Length(A) > 0 then
1391 | for Rev := Length(A) - 1 downto 0 do
1392 | begin
1393 | ;
1394 | ListItem := ListView2.Items.Add;
1395 | ListItem.Caption := A[Rev].revisionid;
1396 | ListItem.SubItems.Add(A[Rev].modifiedTime);
1397 | ListItem.SubItems.Add(A[Rev].originalFileName);
1398 | ListItem.SubItems.Add(A[Rev].mimetype);
1399 | ListItem.SubItems.Add(A[Rev].id);
1400 | end
1401 | else
1402 | begin
1403 | ListItem := ListView2.Items.Add;
1404 | ListItem.Caption := 'no revisions';
1405 | end;
1406 | end;
1407 | end
1408 | else
1409 | begin
1410 | ListItem := ListView2.Items.Add;
1411 | ListItem.Caption := 'error getting revisions';
1412 | end;
1413 |
1414 | end;
1415 |
1416 | procedure TMainform.ListView2DblClick(Sender: TObject);
1417 | var
1418 | FileId, RevisionId, Filename: string;
1419 | begin
1420 | Jdrive.Progress := ProgressBar1;
1421 | RevisionId := ListView2.Selected.Caption;
1422 | FileId := '';
1423 | if (ListView2.Selected.SubItems.Count > 3) then
1424 | begin
1425 | FileId := ListView2.Selected.SubItems.Strings[3];
1426 | Filename := ListView2.Selected.SubItems.Strings[1];
1427 | if Jdrive.DownloadFile(fileid, filename, revisionid) then
1428 | begin
1429 | StatusBar1.SimpleText := Filename + ' downloaded';
1430 | end;
1431 | end;
1432 | end;
1433 |
1434 | procedure TMainform.MenuItem1Click(Sender: TObject);
1435 | var
1436 | FileId, mimetype, originalFilename: string;
1437 | index: integer;
1438 | exp: TGDExportarray;
1439 | begin
1440 | index := Listview1.ItemIndex;
1441 | if index < 0 then exit;
1442 | if Jdrive.gOAuth2.EMail = '' then exit;
1443 | FileId := JDrive.Files[index].fileid;
1444 | mimeType := JDrive.Files[index].mimeType;
1445 | originalFilename := JDrive.Files[index].originalFilename;
1446 | if FileId <> '' then
1447 | begin
1448 | if Pos('application/vnd.google-apps', mimetype) > 0 then exit
1449 | else
1450 | begin
1451 | JDrive.DownloadResumableFile(JDrive.Files[index], originalfilename);
1452 | end;
1453 | end;
1454 | end;
1455 |
1456 | procedure TMainform.MenuItem2Click(Sender: TObject);
1457 | begin
1458 | ShowMessage(IntToStr(Listview1.ItemIndex));
1459 | ShowMessage(JDrive.Files[Listview1.ItemIndex].parents[0].id);
1460 | end;
1461 |
1462 | procedure TMainform.MenuItem4Click(Sender: TObject);
1463 | var
1464 | FileId, Parentid: string;
1465 | index: integer;
1466 | begin
1467 | index := Listview1.ItemIndex;
1468 | if index < 0 then exit;
1469 | if Jdrive.gOAuth2.EMail = '' then exit;
1470 | if not Areyousure then exit;
1471 | FileId := JDrive.Files[index].fileid;
1472 |
1473 | if length(JDrive.Files[index].parents) > 0 then
1474 | ParentId := JDrive.Files[index].parents[0].id
1475 | else
1476 | ParentID := 'root';
1477 |
1478 | Jdrive.DeleteGFile(FileId);
1479 | JDrive.ListFiles(JDrive.Files, [showpreviousfolder, listparents], parentid, 'name,originalFilename,mimeType,id,size,modifiedTime,iconLink,parents,md5Checksum');
1480 | FillDriveView2;
1481 |
1482 | end;
1483 |
1484 | procedure TMainform.Button2Click(Sender: TObject);
1485 | var
1486 | files: TGfiles;
1487 | var
1488 | i: integer;
1489 | begin
1490 | StringGrid3.Options := StringGrid3.Options + [goRowSelect];
1491 | StringGrid3.ColCount := 9;
1492 |
1493 | StringGrid3.RowCount := 2;
1494 | StringGrid3.Cells[1, 0] := 'Title';
1495 | StringGrid3.Cells[2, 0] := 'Created';
1496 | StringGrid3.Cells[3, 0] := 'Modified';
1497 | StringGrid3.Cells[4, 0] := 'Filename';
1498 | StringGrid3.Cells[5, 0] := 'Size';
1499 | StringGrid3.Cells[6, 0] := 'FileId';
1500 | StringGrid3.Cells[7, 0] := 'MimeType';
1501 | StringGrid3.Cells[8, 0] := 'RevisionId';
1502 |
1503 | StringGrid3.AutoFillColumns := False;
1504 |
1505 | JDrive.gOAuth2.LogMemo := Memo1;
1506 | Jdrive.gOAuth2.DebugMemo := Memo2;
1507 | Jdrive.gOAuth2.GetAccess([goDrive], True);
1508 | CheckTokenFile;
1509 |
1510 |
1511 | if Jdrive.gOAuth2.EMail = '' then
1512 | exit;
1513 | JDrive.Open;
1514 | for i := 0 to length(files) - 1 do
1515 | begin
1516 |
1517 | if not ckHideFolders.Checked or not files[i].isFolder then
1518 | begin
1519 | with StringGrid3 do
1520 | begin
1521 | Mainform.Memo1.Lines.add('Processing ...' + IntToStr(i + 1));
1522 | Cells[1, StringGrid3.RowCount - 1] := files[i].Name;
1523 | Cells[2, StringGrid3.RowCount - 1] := files[i].createdTime;
1524 | Cells[3, StringGrid3.RowCount - 1] := files[i].modifiedTime;
1525 | Cells[4, StringGrid3.RowCount - 1] := files[i].originalFilename;
1526 | Cells[5, StringGrid3.RowCount - 1] := files[i].Size;
1527 | Cells[6, StringGrid3.RowCount - 1] := files[i].fileid;
1528 | Cells[7, StringGrid3.RowCount - 1] := files[i].mimeType;
1529 | if files[i].mimeType = 'application/vnd.google-apps.folder' then
1530 | Cells[7, StringGrid3.RowCount - 1] := '';
1531 | if Length(files[i].revisions) > 0 then Cells[8, StringGrid3.RowCount - 1] := files[i].Revisions[0].revisionid;
1532 | end;
1533 |
1534 | StringGrid3.RowCount := StringGrid3.RowCount + 1;
1535 |
1536 | end;
1537 |
1538 | end;
1539 |
1540 | end;
1541 |
1542 | procedure TMainform.Button3Click(Sender: TObject);
1543 | var
1544 | x: integer;
1545 | var
1546 | fileid, revisionid: string;
1547 | begin
1548 | if stringgrid4.RowCount = 2 then
1549 | begin
1550 | ShowMessage('No revision found, you may delete the file');
1551 | exit;
1552 | end;
1553 |
1554 | x := Stringgrid4.Selection.Top;
1555 |
1556 | fileid := StringGrid4.Cells[6, x];
1557 | revisionid := StringGrid4.Cells[8, x];
1558 |
1559 | if QuestionDlg('Question', 'You''re about to delete a revision of the current file, continue anyway ?',
1560 | mtCustom, [1, 'Ok', 2, 'No thanks'], '') = 2 then exit;
1561 |
1562 | JDrive.DeleteGFile(fileid, revisionid);
1563 | end;
1564 |
1565 |
1566 | procedure TMainform.btClearDebugClick(Sender: TObject);
1567 | begin
1568 | Memo2.Clear;
1569 | end;
1570 |
1571 | function Gdrivepostfile(const URL, auth, FileName: string; const Data: TStream; const ResultData: TStrings): boolean;
1572 | var
1573 | HTTP: THTTPSend;
1574 | Bound, s: string;
1575 | begin
1576 | Bound := IntToHex(Random(MaxInt), 8) + '_Synapse_boundary';
1577 | HTTP := THTTPSend.Create;
1578 | try
1579 | s := '--' + Bound + CRLF;
1580 | s := s + 'Content-Type: application/json; charset=UTF-8' + CRLF + CRLF;
1581 | s := s + '{' + CRLF;
1582 | s := s + '"name": "' + ExtractFileName(FileName) + '"' + CRLF;
1583 | s := s + '}' + CRLF + CRLF;
1584 |
1585 | s := s + '--' + Bound + CRLF;
1586 | s := s + 'Content-Type: application/octet-stream' + CRLF + CRLF;
1587 | WriteStrToStream(HTTP.Document, ansistring(s));
1588 | HTTP.Document.CopyFrom(Data, 0);
1589 |
1590 | s := CRLF + '--' + Bound + '--' + CRLF;
1591 | WriteStrToStream(HTTP.Document, ansistring(s));
1592 |
1593 | HTTP.Headers.Add('Authorization: Bearer ' + auth);
1594 | HTTP.MimeType := 'multipart/form-data; boundary=' + Bound;
1595 | Result := HTTP.HTTPMethod('POST', URL);
1596 | Mainform.Memo2.Lines.Add(HTTP.Headers.Text);
1597 |
1598 | if Result then
1599 | ResultData.LoadFromStream(HTTP.Document);
1600 | finally
1601 | HTTP.Free;
1602 | end;
1603 | end;
1604 |
1605 | procedure TMainform.btnSimpleUploadClick(Sender: TObject);
1606 | var
1607 | URL: string;
1608 | Data: TFileStream;
1609 | ResultData: TStringList;
1610 | begin
1611 | // URL := 'https://www.googleapis.com/upload/drive/v3/files?uploadType=media';
1612 | // URL := 'https://www.googleapis.com/upload/drive/v3/files?uploadType=resumable';
1613 | URL := 'https://www.googleapis.com/upload/drive/v3/files?uploadType=multipart';
1614 |
1615 | JDrive.gOAuth2 := TGoogleOAuth2.Create(client_id, client_secret);
1616 | ResultData := TStringList.Create;
1617 | Data := TFileStream.Create('c:\temp\test.txt', fmOpenRead);
1618 | try
1619 | if not FileExists('tokens.dat') then
1620 | begin
1621 | // first get all access clicked on Groupbox
1622 | btGetAccess.Click;
1623 | end;
1624 |
1625 | JDrive.gOAuth2.LogMemo := Memo1;
1626 | JDrive.gOAuth2.DebugMemo := Memo2;
1627 | JDrive.gOAuth2.GetAccess([], True); // <- get from file
1628 | // no need for scope because we should already have access
1629 | // via the btGetAccess for all the scopes in Groupbox
1630 | if JDrive.gOAuth2.EMail = '' then
1631 | exit;
1632 |
1633 | Gdrivepostfile(URL, JDrive.gOAuth2.Access_token, 'test.txt', Data, ResultData);
1634 |
1635 | Memo1.Lines.Add(ResultData.Text);
1636 |
1637 | finally
1638 | Data.Free;
1639 | ResultData.Free;
1640 | JDrive.gOAuth2.Free;
1641 | end;
1642 |
1643 | end;
1644 |
1645 |
1646 | type
1647 | TPendingUpload = packed record
1648 | // id: integer;
1649 | filename: string;
1650 | url: string;
1651 | md5: string;
1652 | description: string;
1653 | // date: tdatetime;
1654 | end;
1655 |
1656 | type
1657 | PendingUploadArray = array of TPendingUpload;
1658 |
1659 | procedure Retrieve_All_upload_files(filename: string; var pendinguploads: PendingUploadArray);
1660 | var
1661 | a: TJSONConfig;
1662 | b: TStringList;
1663 | i: integer;
1664 | begin
1665 | a := TJSONConfig.Create(nil);
1666 | try
1667 | a.Filename := filename;
1668 | b := TStringList.Create;
1669 | Setlength(pendinguploads, 0);
1670 | a.EnumSubKeys('/', b);
1671 | Setlength(pendinguploads, b.Count);
1672 | for i := 0 to b.Count - 1 do
1673 | begin
1674 | with pendinguploads[i] do
1675 | begin
1676 | filename := a.Getvalue(b[i] + '/Filename', '');
1677 | url := a.Getvalue(b[i] + '/URL', '');
1678 | description := a.Getvalue(b[i] + '/Description', '');
1679 | md5 := a.Getvalue(b[i] + '/Md5', '');
1680 | end;
1681 | end;
1682 | finally
1683 | a.Free;
1684 | b.Free;
1685 | end;
1686 | end;
1687 |
1688 |
1689 |
1690 | procedure TMainform.UploadWithResume(fileid: string = ''; settings: TUploadSettings = []);
1691 | const
1692 | BaseURL = 'https://www.googleapis.com/upload/drive/v3/files';
1693 | Param = '';
1694 | Pendingfile = 'Pendingupload.json';
1695 |
1696 | function GetNewUploadFile: TPendingUpload;
1697 | var
1698 | UploadFilename: string;
1699 | UploadURL: string;
1700 | Data: TStream;
1701 | begin
1702 | Result.Url := '';
1703 | UploadFilename := '';
1704 | with TOpenDialog.Create(nil) do
1705 | try
1706 | Execute;
1707 | UploadFilename := Filename;
1708 | finally
1709 | Free;
1710 | end;
1711 |
1712 | if UploadFilename = '' then exit; // aborted
1713 | Result.Description := Edit3.Text;
1714 |
1715 | // add to pending
1716 | Result.filename := Uploadfilename;
1717 | Result.description := Edit3.Text;
1718 | Result.url := ''; // not yet
1719 | Result.md5 := md5print(md5file(UploadFilename));
1720 | ;
1721 |
1722 | Data := TFileStream.Create(UploadFilename, fmOpenRead);
1723 | try
1724 | UploadURL := JDrive.GetUploadURI(BaseURL, JDrive.gOAuth2.Access_token,
1725 | Result.filename, Result.Description, Data, Param, fileid, settings);
1726 | ShowMessage(UploadURL);
1727 | if pos('upload_id', UploadURL) > 0 then
1728 | begin
1729 | Result.url := UploadURL;
1730 | end
1731 | else
1732 | begin
1733 | ShowMessage('Error getting upload_id');
1734 | end;
1735 | finally
1736 | Data.Free;
1737 | end;
1738 |
1739 | end;
1740 |
1741 | var
1742 | Res: string;
1743 | Data: TFileStream;
1744 | Answer: TModalResult;
1745 | md5: string;
1746 | Pending: PendingUploadArray;
1747 | Current: TPendingUpload;
1748 | qUrl: string;
1749 | i, j: integer;
1750 | begin
1751 | // https://developers.google.com/drive/v3/web/manage-uploads
1752 |
1753 | if not FileExists('tokens.dat') then
1754 | begin
1755 | // first get all access clicked on Groupbox
1756 | btGetAccess.Click;
1757 | end;
1758 | try
1759 | JDrive.gOAuth2.LogMemo := Memo1;
1760 | JDrive.gOAuth2.DebugMemo := Memo2;
1761 | JDrive.gOAuth2.GetAccess([], True); // <- get from file
1762 | // no need for scope because we should already have access
1763 | // via the btGetAccess for all the scopes in Groupbox
1764 | if JDrive.gOAuth2.EMail = '' then exit;
1765 |
1766 | SetLength(Pending, 0);
1767 | if FileExists(pendingfile) then
1768 | retrieve_all_upload_files(pendingfile, pending);
1769 |
1770 | Listbox1.Clear;
1771 | for j := 0 to Length(Pending) - 1 do
1772 | ListBox1.Items.Add(Pending[j].filename);
1773 |
1774 | Answer := 2; // don't foget in case hasuploads is false
1775 |
1776 | if Length(pending) > 0 then
1777 | begin
1778 | ;
1779 | Answer := QuestionDlg('Question', 'Previous upload(s) was/were in progress.' + #13 +
1780 | 'Do you want to continue, abort or remove pending-status?',
1781 | mtCustom, [1, 'Continue all', 2, 'Upload another file and continue all', 3, 'Remove status'], '');
1782 | //if Answer = 2 then exit;
1783 | if Answer = 3 then
1784 | begin
1785 | DeleteFile(Pendingfile); // the one in fileutils doesn't need pchar()
1786 | ShowMessage('Pending upload-status removed');
1787 | exit;
1788 | end;
1789 | end;
1790 |
1791 | if Answer = 2 then
1792 | begin // new upload
1793 |
1794 | Current := GetNewUploadFile;
1795 | if Current.Url <> '' then
1796 | begin
1797 | Setlength(pending, Length(Pending) + 1);
1798 | pending[Length(Pending) - 1] := Current;
1799 | // and add it directory to the pendingfile
1800 | SetJsonparam(Pendingfile, Current.filename + '/Filename', Current.filename);
1801 | SetJsonparam(Pendingfile, Current.filename + '/Description', Current.description);
1802 | SetJsonparam(Pendingfile, Current.filename + '/URL', Current.url);
1803 | SetJsonparam(Pendingfile, Current.filename + '/Md5', Current.md5);
1804 | end;
1805 |
1806 | end;
1807 |
1808 | // now the main loop
1809 | for i := 0 to length(pending) - 1 do
1810 | begin
1811 |
1812 | Listbox1.Clear;
1813 | for j := 0 to Length(Pending) - 1 do
1814 | ListBox1.Items.Add(Pending[j].filename);
1815 |
1816 | Current := Pending[i];
1817 | // Memo1.Lines.Add('Result request upload_id = ' + UploadURL);
1818 | md5 := md5print(md5file(Current.filename)); // always before tstream
1819 |
1820 | Data := TFileStream.Create(Current.Filename, fmOpenRead);
1821 | try
1822 |
1823 | if Current.md5 <> md5 then
1824 | begin
1825 | Memo1.Lines.add(Current.filename + ' md5 mismatch');
1826 | // need to reupload
1827 | qURL := JDrive.GetUploadURI(BaseURL, JDrive.gOAuth2.Access_token,
1828 | Current.Filename, Current.Description, Data, Param, fileid, settings);
1829 | if pos('upload_id', qURL) > 0 then
1830 | begin
1831 | Current.url := qURL;
1832 | Current.md5 := md5;
1833 | Pending[i] := Current;
1834 | // and add it directory to the pendingfile
1835 | SetJsonparam(Pendingfile, Current.filename + '/URL', Current.url);
1836 | SetJsonparam(Pendingfile, Current.filename + '/Md5', Current.md5);
1837 | end
1838 | else
1839 | begin
1840 | ShowMessage('Error getting upload_id');
1841 | Continue;
1842 | end;
1843 | end;
1844 |
1845 | // do the transfer in chunks if needed
1846 | Res := JDrive.UploadResumableFile(Current.URL, Data);
1847 | Memo1.Lines.Add(Res);
1848 |
1849 | // remove from pending
1850 | if Copy(Res, 1, 3) = '200' then
1851 | DeleteJSONPath(Pendingfile, Current.filename);
1852 |
1853 | Jdrive.Progress.Position := 0;
1854 |
1855 | finally
1856 | Data.Free;
1857 | end;
1858 |
1859 | end;
1860 |
1861 | finally
1862 | Listbox1.Clear;
1863 | end;
1864 |
1865 | end;
1866 |
1867 |
1868 |
1869 | procedure TMainform.btnUploadWithResumeClick(Sender: TObject);
1870 | begin
1871 | Uploadwithresume;
1872 | end;
1873 |
1874 | procedure TMainform.Button4Click(Sender: TObject);
1875 | var
1876 | x: integer;
1877 | var
1878 | fileid: string;
1879 | begin
1880 | x := Stringgrid4.Selection.Top;
1881 | fileid := stringgrid4.Cells[6, x];
1882 | if fileid = '' then exit;
1883 | uploadwithresume(fileid, [keepforever, renamefile]);
1884 |
1885 | end;
1886 |
1887 | procedure TMainform.TabSheet12Show(Sender: TObject);
1888 | const
1889 | Pendingfile = 'Pendingupload.json';
1890 | var
1891 | Pending: PendingUploadArray;
1892 | j: integer;
1893 | begin
1894 | SetLength(Pending, 0);
1895 | if FileExists(pendingfile) then
1896 | retrieve_all_upload_files(pendingfile, pending);
1897 |
1898 | Listbox1.Clear;
1899 | for j := 0 to Length(Pending) - 1 do
1900 | ListBox1.Items.Add(Pending[j].filename);
1901 |
1902 | end;
1903 |
1904 |
1905 | function TMainform.GetJSONParam(filename, param: string): string;
1906 | var
1907 | a: TJSONConfig;
1908 | begin
1909 | a := TJSONConfig.Create(nil);
1910 | try
1911 | a.Filename := filename;
1912 | Result := a.GetValue(param, '');
1913 | finally
1914 | a.Free;
1915 | end;
1916 | end;
1917 |
1918 | procedure TMainform.SetJSONParam(filename, param, Value: string);
1919 | var
1920 | a: TJSONConfig;
1921 | begin
1922 | a := TJSONConfig.Create(nil);
1923 | try
1924 | a.Formatted := True;
1925 | a.Filename := filename;
1926 | a.SetValue(param, Value);
1927 | finally
1928 | a.Free;
1929 | end;
1930 | end;
1931 |
1932 | procedure TMainform.DeleteJSONPath(filename, param: string);
1933 | var
1934 | a: TJSONConfig;
1935 | begin
1936 | a := TJSONConfig.Create(nil);
1937 | try
1938 | a.Formatted := True;
1939 | a.Filename := filename;
1940 | a.SetValue(param + '/dummy', 'dummy'); // this will make sure changes are detected
1941 | // see http://bugs.freepascal.org/view.php?id=30907
1942 | a.DeletePath(param);
1943 | finally
1944 | a.Free;
1945 | end;
1946 | end;
1947 |
1948 | end.
1949 |
--------------------------------------------------------------------------------
/frmmain_gmail.lfm:
--------------------------------------------------------------------------------
1 | object Mainform: TMainform
2 | Left = 254
3 | Height = 685
4 | Top = 181
5 | Width = 1156
6 | Caption = 'Google OAuth 2.0 testapp for SMTP GMail'
7 | ClientHeight = 685
8 | ClientWidth = 1156
9 | OnCreate = FormCreate
10 | OnDestroy = FormDestroy
11 | Position = poScreenCenter
12 | LCLVersion = '2.3.0.0'
13 | object PageControl6: TPageControl
14 | Left = 0
15 | Height = 685
16 | Top = 0
17 | Width = 1156
18 | ActivePage = TabSheet14
19 | Align = alClient
20 | TabIndex = 0
21 | TabOrder = 0
22 | object TabSheet14: TTabSheet
23 | Caption = 'Google Access'
24 | ClientHeight = 657
25 | ClientWidth = 1148
26 | object Panel1: TPanel
27 | Left = 0
28 | Height = 270
29 | Top = 0
30 | Width = 1148
31 | Align = alTop
32 | ClientHeight = 270
33 | ClientWidth = 1148
34 | TabOrder = 0
35 | object btGetAccess: TButton
36 | Left = 136
37 | Height = 25
38 | Top = 16
39 | Width = 120
40 | Caption = 'Get access'
41 | OnClick = btGetAccessClick
42 | TabOrder = 0
43 | end
44 | object Memo1: TMemo
45 | Left = 11
46 | Height = 111
47 | Top = 148
48 | Width = 1126
49 | Align = alBottom
50 | BorderSpacing.Around = 10
51 | ScrollBars = ssAutoVertical
52 | TabOrder = 1
53 | end
54 | object btRemoveTokens: TButton
55 | Left = 272
56 | Height = 25
57 | Top = 16
58 | Width = 147
59 | Caption = 'Remove tokens.dat'
60 | OnClick = btRemoveTokensClick
61 | TabOrder = 2
62 | end
63 | object btClearLog: TButton
64 | Left = 24
65 | Height = 25
66 | Top = 16
67 | Width = 99
68 | Caption = 'Clear debug'
69 | OnClick = btClearLogClick
70 | TabOrder = 3
71 | end
72 | object CheckGroup1: TCheckGroup
73 | Left = 24
74 | Height = 96
75 | Top = 48
76 | Width = 1104
77 | Anchors = [akTop, akLeft, akRight]
78 | AutoFill = True
79 | Caption = 'Access (scope)'
80 | ChildSizing.LeftRightSpacing = 6
81 | ChildSizing.TopBottomSpacing = 6
82 | ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
83 | ChildSizing.EnlargeVertical = crsHomogenousChildResize
84 | ChildSizing.ShrinkHorizontal = crsScaleChilds
85 | ChildSizing.ShrinkVertical = crsScaleChilds
86 | ChildSizing.Layout = cclTopToBottomThenLeftToRight
87 | ChildSizing.ControlsPerLine = 2
88 | ClientHeight = 76
89 | ClientWidth = 1100
90 | ColumnLayout = clVerticalThenHorizontal
91 | Columns = 3
92 | Items.Strings = (
93 | 'profile (info only)'
94 | 'email (info only)'
95 | 'Access to Mail'
96 | 'Access to Contacts'
97 | 'Access to Calendar'
98 | 'Access to Drive'
99 | )
100 | TabOrder = 4
101 | Data = {
102 | 06000000020202020202
103 | }
104 | end
105 | end
106 | object PageControl1: TPageControl
107 | Left = 0
108 | Height = 387
109 | Top = 270
110 | Width = 1148
111 | ActivePage = TabSheet1
112 | Align = alClient
113 | TabIndex = 0
114 | TabOrder = 1
115 | object TabSheet1: TTabSheet
116 | Caption = 'GMail'
117 | ClientHeight = 359
118 | ClientWidth = 1140
119 | object PageControl2: TPageControl
120 | Left = 10
121 | Height = 339
122 | Top = 10
123 | Width = 1120
124 | ActivePage = TabSheet5
125 | Align = alClient
126 | BorderSpacing.Around = 10
127 | TabIndex = 1
128 | TabOrder = 0
129 | object TabSheet4: TTabSheet
130 | Caption = 'New mail'
131 | ClientHeight = 311
132 | ClientWidth = 1112
133 | object Label1: TLabel
134 | Left = 144
135 | Height = 23
136 | Top = 16
137 | Width = 55
138 | Alignment = taRightJustify
139 | AutoSize = False
140 | Caption = 'From'
141 | Font.Height = -16
142 | Layout = tlCenter
143 | ParentColor = False
144 | ParentFont = False
145 | end
146 | object edSender: TEdit
147 | Left = 216
148 | Height = 23
149 | Top = 16
150 | Width = 886
151 | Anchors = [akTop, akLeft, akRight]
152 | Enabled = False
153 | TabOrder = 0
154 | Text = '(will be filled in automatically during send or GetAccess)'
155 | end
156 | object Label2: TLabel
157 | Left = 144
158 | Height = 23
159 | Top = 48
160 | Width = 56
161 | Alignment = taRightJustify
162 | AutoSize = False
163 | Caption = 'To'
164 | Font.Height = -16
165 | Layout = tlCenter
166 | ParentColor = False
167 | ParentFont = False
168 | end
169 | object edRecipient: TEdit
170 | Left = 216
171 | Height = 23
172 | Top = 48
173 | Width = 886
174 | Anchors = [akTop, akLeft, akRight]
175 | TabOrder = 1
176 | Text = 'recipient@valid_domain.com'
177 | end
178 | object Label3: TLabel
179 | Left = 144
180 | Height = 23
181 | Top = 80
182 | Width = 55
183 | Alignment = taRightJustify
184 | AutoSize = False
185 | Caption = 'Subject'
186 | Font.Height = -16
187 | Layout = tlCenter
188 | ParentColor = False
189 | ParentFont = False
190 | end
191 | object edSubject: TEdit
192 | Left = 216
193 | Height = 23
194 | Top = 80
195 | Width = 886
196 | Anchors = [akTop, akLeft, akRight]
197 | TabOrder = 2
198 | Text = 'Subject'
199 | end
200 | object edBody: TMemo
201 | Left = 10
202 | Height = 188
203 | Top = 113
204 | Width = 1092
205 | Align = alBottom
206 | Anchors = [akTop, akLeft, akRight, akBottom]
207 | BorderSpacing.Around = 10
208 | Lines.Strings = (
209 | 'This is the body of the mail'
210 | )
211 | TabOrder = 3
212 | end
213 | object btSendMail: TButton
214 | Left = 10
215 | Height = 88
216 | Top = 15
217 | Width = 118
218 | Caption = 'Send mail'
219 | OnClick = btSendMailClick
220 | TabOrder = 4
221 | end
222 | end
223 | object TabSheet5: TTabSheet
224 | Caption = 'Inbox'
225 | ClientHeight = 311
226 | ClientWidth = 1112
227 | object btGetInbox: TButton
228 | Left = 10
229 | Height = 41
230 | Top = 15
231 | Width = 118
232 | Caption = 'Get Inbox Mail'
233 | OnClick = btGetInboxClick
234 | TabOrder = 0
235 | end
236 | object StringGrid1: TStringGrid
237 | Left = 10
238 | Height = 237
239 | Top = 64
240 | Width = 1095
241 | Anchors = [akTop, akLeft, akRight, akBottom]
242 | TabOrder = 1
243 | end
244 | end
245 | end
246 | end
247 | object TabSheet8: TTabSheet
248 | Caption = 'Debug'
249 | ClientHeight = 359
250 | ClientWidth = 1140
251 | object Memo2: TMemo
252 | Left = 10
253 | Height = 304
254 | Top = 45
255 | Width = 1120
256 | Align = alClient
257 | BorderSpacing.Around = 10
258 | Lines.Strings = (
259 | 'Memo2'
260 | )
261 | ScrollBars = ssAutoVertical
262 | TabOrder = 0
263 | end
264 | object btClearDebug: TButton
265 | Left = 10
266 | Height = 25
267 | Top = 10
268 | Width = 1120
269 | Align = alTop
270 | BorderSpacing.Around = 10
271 | Caption = 'Clear debugscreen'
272 | TabOrder = 1
273 | end
274 | end
275 | end
276 | end
277 | end
278 | end
279 |
--------------------------------------------------------------------------------
/frmmain_gmail.pas:
--------------------------------------------------------------------------------
1 | unit frmMain_GMail;
2 |
3 | {$mode objfpc}{$H+}
4 |
5 | interface
6 |
7 | uses
8 | Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
9 | ComCtrls, ExtCtrls, Grids, blcksock, fpjson, jsonConf;
10 |
11 | type
12 |
13 | { TMainform }
14 |
15 | TMainform = class(TForm)
16 | btGetAccess: TButton;
17 | btSendMail: TButton;
18 | btRemoveTokens: TButton;
19 | btClearLog: TButton;
20 | btClearDebug: TButton;
21 | btGetInbox: TButton;
22 | CheckGroup1: TCheckGroup;
23 |
24 | edBody: TMemo;
25 | edRecipient: TEdit;
26 | edSender: TEdit;
27 | edSubject: TEdit;
28 | Label1: TLabel;
29 | Label2: TLabel;
30 | Label3: TLabel;
31 | PageControl6: TPageControl;
32 | Memo1: TMemo;
33 | Memo2: TMemo;
34 | PageControl1: TPageControl;
35 | PageControl2: TPageControl;
36 | Panel1: TPanel;
37 | StringGrid1: TStringGrid;
38 | TabSheet1: TTabSheet;
39 | TabSheet14: TTabSheet;
40 | TabSheet4: TTabSheet;
41 | TabSheet5: TTabSheet;
42 | TabSheet8: TTabSheet;
43 | procedure btGetAccessClick(Sender: TObject);
44 | procedure btGetInboxClick(Sender: TObject);
45 | procedure btSendMailClick(Sender: TObject);
46 | procedure btRemoveTokensClick(Sender: TObject);
47 | procedure btClearLogClick(Sender: TObject);
48 | procedure FormCreate(Sender: TObject);
49 | procedure FormDestroy(Sender: TObject);
50 | private
51 | { private declarations }
52 | protected
53 | public
54 | { public declarations }
55 | procedure AddToLog(Str: string);
56 | procedure CheckTokenFile;
57 | end;
58 |
59 | var
60 | Mainform: TMainform;
61 |
62 |
63 | implementation
64 |
65 | uses
66 | google_oauth2,
67 | smtpsend,
68 | imapsend,
69 | mimemess,
70 | synautil;
71 |
72 | {$R *.lfm}
73 |
74 | { TMainform }
75 |
76 | var
77 | client_id: string = '504681931309-gc0n3bqtr0dgp6se1d7ee6pcean7heho.apps.googleusercontent.com';
78 | client_secret: string = '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'; // only valid for my own test-user ( 2023-01-12 )
79 |
80 | procedure TMainform.AddToLog(Str: string);
81 | begin
82 | Memo1.Lines.Add(Str);
83 | end;
84 |
85 | procedure TMainform.CheckTokenFile;
86 | begin
87 |
88 | if FileExists('tokens.dat') then // already tokens
89 | begin
90 | CheckGroup1.Enabled := False;
91 | CheckGroup1.Caption := 'Access (scope) remove tokens.dat first to get new access';
92 | btGetAccess.Caption := 'Check access';
93 | end
94 | else
95 | begin
96 | CheckGroup1.Enabled := True;
97 | CheckGroup1.Caption := 'Access (scope)';
98 | btGetAccess.Caption := 'Get access';
99 | end;
100 |
101 | end;
102 |
103 | procedure TMainform.FormCreate(Sender: TObject);
104 | var
105 | Cfg: TJSONConfig;
106 | begin
107 |
108 | Memo1.Clear;
109 | Memo2.Clear;
110 |
111 | Cfg := TJSONConfig.Create(nil);
112 | try
113 | cfg.Filename := 'client.json';
114 | client_id := cfg.GetValue('installed/client_id', client_id);
115 | client_secret := cfg.GetValue('installed/client_secret', client_secret);
116 | finally
117 | Cfg.Free;
118 | end;
119 |
120 | if Pos('504681931309', client_id) = 1 then // default client_id
121 | begin
122 | AddToLog('Using client_id from sourcecode (' + client_id + ')');
123 | AddToLog('You need to create your own project and download the client.json');
124 | AddToLog('See README.md for information');
125 | end
126 | else
127 | begin
128 | AddToLog('Using client_id from file client.json (' + client_id + ')');
129 | end;
130 |
131 | Width := round(Screen.Width * 0.6);
132 | Height := round(Screen.Height * 0.9) - 100;
133 | Top := 100;
134 |
135 | CheckGroup1.Checked[0] := True;
136 | CheckGroup1.Checked[1] := True;
137 | CheckGroup1.Checked[2] := True;
138 | CheckGroup1.CheckEnabled[0] := False;
139 | CheckGroup1.CheckEnabled[1] := False;
140 |
141 | PageControl1.ActivePageIndex := 0;
142 |
143 | CheckTokenFile;
144 |
145 | end;
146 |
147 | procedure TMainform.FormDestroy(Sender: TObject);
148 | begin
149 | end;
150 |
151 | procedure TMainform.btGetAccessClick(Sender: TObject);
152 | var
153 | gOAuth2: TGoogleOAuth2;
154 | Scopes: GoogleScopeSet;
155 | begin
156 | // Onetime authentication
157 | // Save tokens to tokens.dat
158 | gOAuth2 := TGoogleOAuth2.Create(client_id, client_secret);
159 | try
160 |
161 | Scopes := [];
162 | if CheckGroup1.Checked[2] then Include(Scopes, goMail);
163 | if CheckGroup1.Checked[3] then Include(Scopes, goContacts);
164 | if CheckGroup1.Checked[4] then Include(Scopes, goCalendar);
165 | if CheckGroup1.Checked[5] then Include(Scopes, goDrive);
166 |
167 | gOAuth2.LogMemo := Memo1;
168 | gOAuth2.DebugMemo := Memo2;
169 | gOAuth2.GetAccess(Scopes, True); // <- get from file
170 |
171 | if gOAuth2.EMail <> '' then
172 | begin
173 | edSender.Text := format('%s <%s>', [gOAuth2.FullName, gOAuth2.EMail]);
174 | if (edRecipient.Text = '') or (edRecipient.Text = 'recipient@valid_domain.com') then
175 | edRecipient.Text := format('%s', [gOAuth2.EMail]);
176 | end;
177 |
178 | CheckTokenFile;
179 |
180 | finally
181 | gOAuth2.Free;
182 | end;
183 |
184 | end;
185 |
186 | procedure TMainform.btRemoveTokensClick(Sender: TObject);
187 | begin
188 | if not FileExists('tokens.dat') then
189 | begin
190 | AddToLog('tokens.dat does not exist');
191 | exit;
192 | end;
193 |
194 | Deletefile('tokens.dat');
195 |
196 | if not FileExists('tokens.dat') then
197 | AddToLog('tokens.dat deleted')
198 | else
199 | AddToLog('error while removing tokens.dat');
200 |
201 | CheckTokenFile;
202 |
203 | end;
204 |
205 | // -----------------------------------------------------
206 | // Little hack for TSMTPSend to give the command XOAUTH2
207 | // -----------------------------------------------------
208 |
209 | type
210 | TmySMTPSend = class helper for TSMTPSend
211 | public
212 | function DoXOAuth2(const Value: string): boolean;
213 | function ChallengeError(): string;
214 | end;
215 |
216 | function TmySMTPSend.DoXOAuth2(const Value: string): boolean;
217 | var
218 | x: integer;
219 | s: string;
220 | begin
221 | Sock.SendString('AUTH XOAUTH2 ' + Value + CRLF);
222 | repeat
223 | s := Sock.RecvString(FTimeout);
224 | if Sock.LastError <> 0 then
225 | Break;
226 | until Pos('-', s) <> 4;
227 | x := StrToIntDef(Copy(s, 1, 3), 0);
228 | Result := (x = 235);
229 | end;
230 |
231 | function TmySMTPSend.ChallengeError(): string;
232 | var
233 | s: string;
234 | begin
235 | Result := '';
236 | Sock.SendString('' + CRLF);
237 | repeat
238 | s := Sock.RecvString(FTimeout);
239 | if Sock.LastError <> 0 then
240 | Break;
241 | if Result <> '' then
242 | Result := Result + CRLF;
243 | Result := Result + s;
244 | until Pos('-', s) <> 4;
245 | end;
246 |
247 | type
248 | TmyIMAPSend = class(TIMAPSend)
249 | protected
250 | function DoXOAuth2(const Value: string): boolean;
251 | public
252 | OAuth2: string;
253 | function Login: boolean;
254 | function ChallengeError(): string;
255 | end;
256 |
257 | function TmyIMAPSend.DoXOAuth2(const Value: string): boolean;
258 | var
259 | S: string;
260 | begin
261 | S := IMAPcommand('AUTHENTICATE XOAUTH2 ' + Value);
262 | Result := S = 'OK';
263 | // Showmessage(S);
264 | // x := StrToIntDef(Copy(S, 1, 3), 0);
265 | // Result := (x = 235);
266 | end;
267 |
268 |
269 | function TmyIMAPSend.Login: boolean;
270 | var
271 | S: string;
272 | begin
273 | FSelectedFolder := '';
274 | FSelectedCount := 0;
275 | FSelectedRecent := 0;
276 | FSelectedUIDvalidity := 0;
277 | Result := False;
278 | FAuthDone := False;
279 | if not Connect then
280 | Exit;
281 | S := string(FSock.RecvString(FTimeout));
282 | if Pos('* PREAUTH', S) = 1 then
283 | FAuthDone := True
284 | else
285 | if Pos('* OK', S) = 1 then
286 | FAuthDone := False
287 | else
288 | Exit;
289 | if Capability then
290 | begin
291 | // * CAPABILITY IMAP4rev1 UNSELECT IDLE NAMESPACE QUOTA ID XLIST CHILDREN X-GM-EXT-1
292 | // XYZZY SASL-IR AUTH=XOAUTH2 AUTH=PLAIN AUTH=PLAIN-CLIENTTOKEN AUTH=OAUTHBEARER AUTH=XOAUTH
293 | // Showmessage(FullResult.Text);
294 | if Findcap('IMAP4rev1') = '' then
295 | Exit;
296 | if FAutoTLS and (Findcap('STARTTLS') <> '') then
297 | if StartTLS then
298 | Capability;
299 | end;
300 |
301 | // Alleen dit is gewijzigd
302 | if OAuth2 <> '' then
303 | Result := DoXOAuth2(OAuth2)
304 | else
305 | Result := AuthLogin;
306 |
307 | end;
308 |
309 | function TmyIMAPSend.ChallengeError(): string;
310 | var
311 | s: string;
312 | begin
313 | Result := '';
314 | Sock.SendString('' + CRLF);
315 | repeat
316 | s := Sock.RecvString(FTimeout);
317 | if Sock.LastError <> 0 then
318 | Break;
319 | if Result <> '' then
320 | Result := Result + CRLF;
321 | Result := Result + s;
322 | until Pos('-', s) <> 4;
323 | end;
324 |
325 | // -----------------------------------------------------
326 | // -----------------------------------------------------
327 |
328 | procedure TMainform.btSendMailClick(Sender: TObject);
329 | var
330 | gOAuth2: TGoogleOAuth2;
331 | smtp: TSMTPSend;
332 | msg_lines: TStringList;
333 | begin
334 | if (edRecipient.Text = '') or (edRecipient.Text = 'recipient@valid_domain.com') then
335 | begin
336 | Memo1.Lines.Add('Please change the recipient');
337 | exit;
338 | end;
339 |
340 | if not FileExists('tokens.dat') then
341 | begin
342 | // first get all access clicked on Groupbox
343 | btGetAccess.Click;
344 | end;
345 |
346 | gOAuth2 := TGoogleOAuth2.Create(client_id, client_secret);
347 | smtp := TSMTPSend.Create;
348 | msg_lines := TStringList.Create;
349 | try
350 | btSendMail.Enabled := False;
351 |
352 | // first get oauthToken
353 | gOAuth2.LogMemo := Memo1;
354 | gOAuth2.DebugMemo := Memo2;
355 | gOAuth2.GetAccess([], True); // <- get from file
356 | // no need for scope because we should already have access
357 | // via the btGetAccess for all the scopes in Groupbox
358 | if gOAuth2.EMail = '' then
359 | exit;
360 |
361 | CheckTokenFile;
362 |
363 | edSender.Text := format('%s <%s>', [gOAuth2.FullName, gOAuth2.EMail]);
364 |
365 | msg_lines.Add('From: ' + edSender.Text);
366 | msg_lines.Add('To: ' + edRecipient.Text);
367 | msg_lines.Add('Subject: ' + edSubject.Text);
368 | msg_lines.Add('');
369 | msg_lines.Add(edBody.Text);
370 |
371 | smtp.TargetHost := 'smtp.gmail.com';
372 | smtp.TargetPort := '587';
373 |
374 | AddToLog('SMTP Login');
375 | if not smtp.Login() then
376 | begin
377 | AddToLog('SMTP ERROR: Login:' + smtp.EnhCodeString);
378 | exit;
379 | end;
380 | if not smtp.StartTLS() then
381 | begin
382 | AddToLog('SMTP ERROR: StartTLS:' + smtp.EnhCodeString);
383 | exit;
384 | end;
385 |
386 | AddToLog('XOAUTH2');
387 | if not smtp.DoXOAuth2(gOAuth2.GetXOAuth2Base64) then
388 | begin
389 | AddToLog('XOAUTH2 ERROR: ' + CRLF + smtp.ChallengeError());
390 | exit;
391 | end;
392 |
393 | AddToLog('SMTP Mail');
394 | if not smtp.MailFrom(gOAuth2.EMail, Length(gOAuth2.EMail)) then
395 | begin
396 | AddToLog('SMTP ERROR: MailFrom:' + smtp.EnhCodeString);
397 | exit;
398 | end;
399 | if not smtp.MailTo(edRecipient.Text) then
400 | begin
401 | AddToLog('SMTP ERROR: MailTo:' + smtp.EnhCodeString);
402 | exit;
403 | end;
404 | if not smtp.MailData(msg_lines) then
405 | begin
406 | AddToLog('SMTP ERROR: MailData:' + smtp.EnhCodeString);
407 | exit;
408 | end;
409 |
410 | AddToLog('SMTP Logout');
411 | if not smtp.Logout() then
412 | begin
413 | AddToLog('SMTP ERROR: Logout:' + smtp.EnhCodeString);
414 | exit;
415 | end;
416 |
417 | AddToLog('OK !');
418 |
419 | finally
420 | gOAuth2.Free;
421 | smtp.Free;
422 | msg_lines.Free;
423 | btSendMail.Enabled := True;
424 | end;
425 |
426 | end;
427 |
428 | procedure TMainform.btGetInboxClick(Sender: TObject);
429 | var
430 | gOAuth2: TGoogleOAuth2;
431 | Imap: TmyIMAPSend;
432 | msgs: TStringList;
433 | MimeMess: TMimeMess;
434 | Ok: boolean;
435 | I: integer;
436 | begin
437 |
438 | StringGrid1.Options := StringGrid1.Options + [goRowSelect];
439 | StringGrid1.ColCount := 5;
440 | StringGrid1.RowCount := 2;
441 | StringGrid1.Cells[1, 0] := 'Date';
442 | StringGrid1.Cells[2, 0] := 'From';
443 | StringGrid1.Cells[3, 0] := 'Subject';
444 | StringGrid1.Cells[4, 0] := 'Size';
445 |
446 | if not FileExists('tokens.dat') then
447 | begin
448 | // first get all access clicked on Groupbox
449 | btGetAccess.Click;
450 | end;
451 |
452 | gOAuth2 := TGoogleOAuth2.Create(client_id, client_secret);
453 | Imap := TmyIMAPSend.Create;
454 | try
455 | btGetInbox.Enabled := False;
456 |
457 | // first get oauthToken
458 | gOAuth2.LogMemo := Memo1;
459 | gOAuth2.DebugMemo := Memo2;
460 | gOAuth2.GetAccess([], True); // <- get from file
461 | // no need for scope because we should already have access
462 | // via the btGetAccess for all the scopes in Groupbox
463 | if gOAuth2.EMail = '' then
464 | exit;
465 |
466 | CheckTokenFile;
467 |
468 | // https://developers.google.com/gmail/imap_extensions?csw=1
469 | Imap.AutoTLS := False;
470 |
471 | // https://myaccount.google.com/apppasswords
472 | // no need for password via OAuth2
473 | Imap.Username := ''; // xxx@gmail.com
474 | Imap.Password := ''; // yyy
475 |
476 | Imap.OAuth2 := gOAuth2.GetXOAuth2Base64;
477 | Imap.TargetHost := 'imap.gmail.com';
478 | Imap.TargetPort := '993';
479 | Imap.FullSSL := True;
480 | Imap.Sock.SSL.SSLType := LT_all;
481 | // Imap.Sock.SSLDoConnect();
482 | if not Imap.Login() then
483 | begin
484 | Memo1.Lines.Add('Login failed ' + Imap.ChallengeError);
485 | exit;
486 | end;
487 |
488 | Ok := Imap.SelectROFolder('INBOX'); // Note that GMail is language sensitive
489 | if not Ok then Ok := Imap.SelectFolder('[Gmail]/Drafts');
490 | if not Ok then
491 | begin
492 | Memo1.Lines.Add('SelectFolder failed');
493 | Imap.Logout();
494 | Exit;
495 | end;
496 |
497 | msgs := TStringList.Create;
498 | MimeMess := TMimeMess.Create;
499 | try
500 |
501 | Imap.SearchMess('ALL', msgs);
502 | StringGrid1.RowCount := msgs.Count + 1;
503 |
504 | for I := 0 to msgs.Count - 1 do
505 | begin
506 | Imap.FetchHeader(StrToInt(msgs.Strings[I]), MimeMess.Lines);
507 | MimeMess.DecodeMessage;
508 | StringGrid1.Cells[1, I + 1] := DateTimeToStr(MimeMess.Header.Date);
509 | StringGrid1.Cells[2, I + 1] := MimeMess.Header.From;
510 | StringGrid1.Cells[3, I + 1] := MimeMess.Header.Subject;
511 | StringGrid1.Cells[4, I + 1] := MimeMess.Header.MessageID;
512 | end;
513 |
514 | finally
515 | msgs.Free;
516 | MimeMess.Free;
517 | end;
518 |
519 | StringGrid1.AutoSizeColumns;
520 |
521 | Imap.Logout();
522 |
523 | finally
524 | gOAuth2.Free;
525 | imap.Free;
526 | btGetInbox.Enabled := True;
527 | end;
528 |
529 | end;
530 |
531 | procedure TMainform.btClearLogClick(Sender: TObject);
532 | begin
533 | Memo1.Clear;
534 | end;
535 |
536 | end.
537 |
--------------------------------------------------------------------------------
/google_calendar.pas:
--------------------------------------------------------------------------------
1 | unit google_calendar;
2 |
3 | {$IFDEF FPC}
4 | {$mode objfpc}{$H+}
5 | {$ENDIF}
6 |
7 | interface
8 |
9 | uses
10 | Classes, SysUtils, DB, Forms, google_oauth2, fpjson, jsonparser, memds;
11 |
12 | type
13 | TGoogleCalendar = class(TMemDataSet)
14 | private
15 | { private declarations }
16 | FgOAuth2: TGoogleOAuth2;
17 | LastErrorCode: string;
18 | LastErrorMessage: string;
19 | protected
20 | { protected declarations }
21 | public
22 | { public declarations }
23 | constructor Create(AOwner: TComponent; client_id, client_secret: string); overload;
24 | destructor Destroy; override;
25 | procedure Populate(aFilter: string = '');
26 |
27 | property gOAuth2: TGoogleOAuth2 read FgOAuth2 write FgOAuth2;
28 | published
29 | end;
30 |
31 |
32 | implementation
33 |
34 | uses httpsend;
35 |
36 | constructor TGoogleCalendar.Create(AOwner: TComponent; client_id, client_secret: string);
37 | begin
38 | inherited Create(AOwner);
39 | FieldDefs.Clear;
40 | //FieldDefs.Add('Boolean', ftBoolean, 0, False);
41 | //FieldDefs.Add('Integer', ftInteger, 0, False);
42 | //FieldDefs.Add('SmallInt', ftSmallInt, 0, False);
43 | //FieldDefs.Add('Float', ftFloat, 0, False);
44 | //FieldDefs.Add('String', ftString, 30, False);
45 | //FieldDefs.Add('Time', ftTime, 0, False);
46 | //FieldDefs.Add('Date', ftDate, 0, False);
47 | //FieldDefs.Add('DateTime', ftDateTime, 0, False);
48 | FieldDefs.Add('start', ftString, 25, False);
49 | FieldDefs.Add('end', ftString, 25, False);
50 | FieldDefs.Add('summary', ftString, 255, False);
51 | FieldDefs.Add('htmllink', ftString, 255, False);
52 | CreateTable;
53 |
54 | gOAuth2 := TGoogleOAuth2.Create(client_id, client_secret);
55 |
56 | end;
57 |
58 | destructor TGoogleCalendar.Destroy;
59 | begin
60 | gOAuth2.Free;
61 | inherited Destroy;
62 | end;
63 |
64 | function RetrieveJSONValue(JSON: TJSONData; Value: string): string;
65 | var
66 | D: TJSONData;
67 | begin
68 | Result := '';
69 | if Assigned(JSON) then
70 | begin
71 | D := JSON.FindPath(Value);
72 | if assigned(D) then
73 | Result := D.AsString;
74 | end;
75 | end;
76 |
77 |
78 | procedure TGoogleCalendar.Populate(aFilter: string = '');
79 | var
80 | Response: TStringList;
81 | URL: string;
82 | Params: string;
83 | P: TJSONParser;
84 | I: integer;
85 | J, D, E: TJSONData;
86 | StartDt: string;
87 | EndDt: string;
88 | begin
89 |
90 | (*
91 | {
92 | "kind": "calendar#event",
93 | "etag": "\"2847129938594000\"",
94 | "id": "0hbjgoqstouc0olq6s0rs0rb4k",
95 | "status": "confirmed",
96 | "htmlLink": "https://www.google.com/calendar/event?eid=MGhiamdvcXN0b3VjMG9scTZzMHJzMHJiNGsgcmlrLnZhbi5rZWtlbUBt",
97 | "created": "2015-02-10T10:19:08.000Z",
98 | "updated": "2015-02-10T10:42:49.297Z",
99 | "summary": "Lloyd voor dorpel",
100 | "start": {
101 | "dateTime": "2012-05-18T15:45:00+02:00"
102 | },
103 | "end": {
104 | "dateTime": "2012-05-18T16:00:00+02:00"
105 | },
106 | "iCalUID": "0hbjgoqstouc0olq6s0rs0rb4k@google.com"
107 | },
108 | *)
109 |
110 | Response := TStringList.Create;
111 | Self.DisableControls;
112 | try
113 |
114 | if gOAuth2.EMail = '' then
115 | exit;
116 |
117 | gOAuth2.LogLine('Retrieving Calendar ' + gOAuth2.EMail);
118 | URL := 'https://www.googleapis.com/calendar/v3/calendars/' +
119 | gOAuth2.EMail + '/events';
120 | Params := 'access_token=' + gOAuth2.Access_token;
121 | Params := Params + '&maxResults=2500';
122 | if HttpGetText(URL + '?' + Params, Response) then
123 | begin
124 | P := TJSONParser.Create(Response.Text);
125 | try
126 | J := P.Parse;
127 | if Assigned(J) then
128 | begin
129 |
130 | D := J.FindPath('error');
131 | if assigned(D) then
132 | begin
133 | LastErrorCode := RetrieveJSONValue(D, 'code');
134 | LastErrorMessage := RetrieveJSONValue(D, 'message');
135 | gOAuth2.LogLine(format('Error %s: %s',
136 | [LastErrorCode, LastErrorMessage]));
137 | exit;
138 | end;
139 |
140 | gOAuth2.DebugLine('Name: ' + RetrieveJSONValue(J, 'summary'));
141 | gOAuth2.DebugLine('Updated: ' + RetrieveJSONValue(J, 'updated'));
142 | gOAuth2.DebugLine('Timezone: ' + RetrieveJSONValue(J, 'timeZone'));
143 | gOAuth2.DebugLine('Next page: ' + RetrieveJSONValue(J, 'nextPageToken'));
144 | gOAuth2.DebugLine('Next sync: ' + RetrieveJSONValue(J, 'nextSyncToken'));
145 |
146 | gOAuth2.LogLine('Busy filling dataset');
147 |
148 | D := J.FindPath('items');
149 | gOAuth2.DebugLine(format('%d items received', [D.Count]));
150 | for I := 0 to D.Count - 1 do
151 | begin
152 | E := D.Items[I].FindPath('start');
153 | StartDt := RetrieveJSONValue(E, 'dateTime');
154 | if StartDt = '' then
155 | StartDt := RetrieveJSONValue(E, 'date');
156 |
157 | E := D.Items[I].FindPath('end');
158 | EndDt := RetrieveJSONValue(E, 'dateTime');
159 | if EndDt = '' then
160 | EndDt := RetrieveJSONValue(E, 'date');
161 |
162 | Append;
163 | // 2015-02-10T10:42:49.297Z
164 | // 2012-05-18T15:45:00+02:00
165 | FieldByName('start').AsString := StartDt;
166 | FieldByName('end').AsString := EndDt;
167 | FieldByName('summary').AsString :=
168 | RetrieveJSONValue(D.Items[I], 'summary');
169 | FieldByName('htmllink').AsString :=
170 | RetrieveJSONValue(D.Items[I], 'htmlLink');
171 | Self.Post;
172 | Application.ProcessMessages;
173 |
174 | end;
175 |
176 | gOAuth2.LogLine(format('%d items stored', [Self.RecordCount]));
177 |
178 | gOAuth2.LogLine('Done filling dataset');
179 |
180 | end;
181 | finally
182 | if assigned(J) then
183 | J.Free;
184 | P.Free;
185 | end;
186 |
187 | end;
188 |
189 |
190 | finally
191 | Response.Free;
192 | Self.EnableControls;
193 | end;
194 |
195 | end;
196 |
197 |
198 |
199 | (*
200 |
201 | Open;
202 | D:=now;
203 | ACount:=1000;
204 | for I:=1 to ACount do
205 | begin
206 | Append;
207 | FieldByName('Boolean').AsBoolean:=False;
208 | FieldByName('Integer').AsInteger:=I;
209 | FieldByName('SmallInt').AsInteger:=I;
210 | FieldByName('Float').AsFloat:=I/10;
211 | FieldByName('String').AsString:='Test-Data '+IntToStr(I);
212 | FieldByName('Time').AsDateTime:=D;
213 | FieldByName('Date').AsDateTime:=D;
214 | Post;
215 | end;
216 | First;
217 | ACount:=0;
218 | While Not EOF do
219 | begin
220 | Inc(ACount);
221 | Writeln('Record ',ACount,' : ');
222 | Writeln('------------------------');
223 | For I:=0 to Fields.Count-1 do
224 | Writeln(Fields[I].FieldName,' : ',Fields[I].AsString);
225 | Writeln;
226 | Next;
227 | end;
228 | Writeln('Total data size : ',DataSize);
229 | If (ParamCount>0) then
230 | FileName:=ParamStr(1);
231 | Close;
232 |
233 | *)
234 |
235 |
236 |
237 | end.
238 |
--------------------------------------------------------------------------------
/google_drive.pas:
--------------------------------------------------------------------------------
1 | unit google_drive;
2 |
3 | {$IFDEF FPC}
4 | {$mode objfpc}{$H+}
5 | {$ENDIF}
6 |
7 | interface
8 |
9 | uses
10 | Classes, SysUtils, DB, Forms, google_oauth2, fpjson, jsonparser, memds,
11 | httpsend, blcksock, typinfo, ComCtrls, synautil, StdCtrls, md5;
12 |
13 | type TGDExport = record
14 | Description : string;
15 | MimeType : string;
16 | FileExtension : string;
17 | end;
18 |
19 | type TGDExportArray = array of TGDExport;
20 |
21 | const GoogleDocumentsExport : TGDExportArray =
22 | (
23 | (Description:'HTML';MimeType:'text/html';FileExtension:'.html'),
24 | (Description:'Plain Text';MimeType:'text/plain';FileExtension:'.txt'),
25 | (Description:'Rich text';MimeType:'application/rtf';FileExtension:'.rtf'),
26 | (Description:'Open Office';MimeType:'application/vnd.oasis.opendocument.text';FileExtension:'.odt'),
27 | (Description:'PDF';MimeType:'application/pdf';FileExtension:'.pdf'),
28 | (Description:'MS Word document';MimeType:'application/vnd.openxmlformats-officedocument.wordprocessingml.document';FileExtension:'.docx')
29 | ) ;
30 |
31 | const GoogleSpreadsheetsExport : TGDExportArray =
32 | (
33 | (Description:'MS Excel';MimeType:'application/vnd.openxmlformats-officedocument.spreadsheetml.sheet';FileExtension:'.xlsx'),
34 | (Description:'Open Office sheet';MimeType:'application/x-vnd.oasis.opendocument.spreadsheet';FileExtension:'.ods'),
35 | (Description:'PDF';MimeType:'application/pdf';FileExtension:'.pdf'),
36 | (Description:'CSV (first sheet only)';MimeType:'text/csv';FileExtension:'.csv')
37 | ) ;
38 |
39 | const GoogleDrawingsExport : TGDExportArray =
40 | (
41 | (Description:'JPEG';MimeType:'image/jpeg';FileExtension:'.jpg'),
42 | (Description:'PNG';MimeType:'image/png';FileExtension:'.png'),
43 | (Description:'SVG';MimeType:'image/svg+xml';FileExtension:'.svg'),
44 | (Description:'PDF';MimeType:'application/pdf';FileExtension:'.pdf')
45 | ) ;
46 |
47 |
48 | const GooglePresentationsExport : TGDExportArray =
49 | (
50 | (Description:'MS PowerPoint';MimeType:'application/vnd.openxmlformats-officedocument.presentationml.presentation';FileExtension:'.pptx'),
51 | (Description:'Plain text';MimeType:'text/plain';FileExtension:'.txt'),
52 | (Description:'PDF';MimeType:'application/pdf';FileExtension:'.pdf')
53 | ) ;
54 |
55 | type apiver = (v2, v3);
56 |
57 | const UploadURL = 'https://www.googleapis.com/upload/drive/v3/files';
58 | const MetaDataURL = 'https://www.googleapis.com/drive/v3/files';
59 |
60 | type TUploadSetting = (RenameFile, KeepForever);
61 | type TUploadSettings = set of TUploadSetting;
62 |
63 |
64 | type Tlistsetting = (listrevisions, listparents, showpreviousfolder);
65 | type Tlistsettings = set of Tlistsetting;
66 |
67 | type TGFileParent = packed record
68 | id: string;
69 | end;
70 |
71 | type TGFileParents = array of TGFileParent;
72 |
73 |
74 | type TCustomPropertyAs = (asstring, asboolean, aslist, asinteger, aselse);
75 | type TCustomProperty = packed record
76 | name : string;
77 | value : string;
78 | end;
79 |
80 | type TCustomProperties = array of TCustomProperty;
81 |
82 | type TGFileRevision = packed record
83 | id: string;
84 | revisionid: string;
85 | size: string;
86 | modifiedTime: string;
87 | mimetype: string;
88 | originalFileName: string;
89 | end;
90 |
91 | type TGFileRevisions = array of TGfileRevision;
92 |
93 | type TGFile = packed record
94 | name: string;
95 | fileid: string;
96 | description: string;
97 | createdTime: string;
98 | modifiedTime: string;
99 | downloadUrl: string;
100 | originalFilename: string;
101 | md5Checksum: string;
102 | size: string;
103 | mimeType: string;
104 | iconLink: string;
105 | isFolder: boolean;
106 | headRevisionId: string;
107 | trashed: boolean;
108 | revisions: TGFilerevisions;
109 | parents: TGFileParents;
110 | end;
111 |
112 | type TGFiles = array of TGfile;
113 |
114 | type TGoogleDriveInformation= packed record
115 | rootFolderId:string;
116 | limit:int64;
117 | usage:int64;
118 | usageInDrive:int64;
119 | usageInDriveTrash:int64;
120 | end;
121 |
122 | type
123 | TGoogleDrive = class(TMemDataSet)
124 | private
125 | { private declarations }
126 | const MaxResults: integer = 500;
127 | var
128 | CancelCur: boolean;
129 | CurFolder:string;
130 | FgOAuth2: TGoogleOAuth2;
131 | LastErrorCode: string;
132 | LastErrorMessage: string;
133 | Bytes: integer;
134 | MaxBytes: integer;
135 | downHTTP: THTTPSend;
136 | FLogMemo: TMemo;
137 | FDebugMemo: TMemo;
138 | FProgress: TProgressBar;
139 | procedure DownStatus(Sender: TObject; Reason: THookSocketReason;
140 | const Value: string);
141 | function GetSizeFromHeader(Header: string): integer;
142 | procedure UpStatus(Sender: TObject; Reason: THookSocketReason; const Value: string);
143 | function ParseMetadata(A:TJSONData;settings:TlistSettings):TGFile;
144 |
145 | Function ExtractQueryProperties:string;
146 | Function ExtractBodyProperties:string;
147 |
148 | protected
149 | { protected declarations }
150 | public
151 | { public declarations }
152 |
153 | var Files: TGFiles;
154 |
155 | var CustomBodyProperties : TCustomProperties;
156 | var CustomQueryProperties : TCustomProperties;
157 |
158 | constructor Create(AOwner: TComponent; client_id, client_secret: string); overload;
159 | destructor Destroy; override;
160 |
161 | procedure Populate(aFilter: string = '');
162 | function DownloadFile(id, TargetFile: string; revisionid: string = ''; exportmimetype : string = ''): boolean;
163 | function DownloadResumableFile(JFile: TGFile; TargetFile: string; revisionid: string = ''; exportmimetype : string = ''): boolean;
164 |
165 | function GetUploadURI(const URL, auth, FileN, Description: string;const Data: TStream; parameters: string = ''; fileid: string = ''; settings : TuploadSettings = [] ): string;
166 |
167 | property gOAuth2: TGoogleOAuth2 read FgOAuth2 write FgOAuth2;
168 | property CurrentFolder:string read CurFolder write CurFolder;
169 | property Progress: TProgressBar read Fprogress write Fprogress;
170 | property GFiles: TGFiles read Files write Files;
171 | property LogMemo: TMemo read FLogMemo write FLogMemo;
172 | property DebugMemo: TMemo read FDebugMemo write FDebugMemo;
173 | property CancelCurrent: boolean read CancelCur write CancelCur;
174 | function UploadResumableFile(const URL: string; const Data: TStream): string;
175 | procedure CreateFolder(foldername: string; parentid: string = '');
176 |
177 | Procedure ClearAllCustomProperties;
178 | Procedure AddCustomProperty(var customproperty:TCustomproperties;cname,cvalue:string; PropAs : TCustomPropertyAs = aselse);
179 |
180 | Function SetFileProperties(id : string):string;
181 | Function SetGFileProperties(Gfile:TGfile):string;
182 | Function SetGFileRevisionProperties(Gfilerev:TGfileRevision):string;
183 |
184 |
185 | function GetRevisions(fileid: string): TGFileRevisions;
186 | procedure GetGFileRevisions(var A: TGFile);
187 |
188 | function DeleteGFile(fileid:string; revisionid: string=''): boolean;
189 | function DeleteGFileRevision(var A: TGFileRevision): boolean;
190 | function DeleteAllGFileRevisions(var A: TGFileRevisions): boolean;
191 |
192 | function GetGFileMetadata(id:string;settings:TListSettings;customfields:string='*'):TGFile;
193 | procedure ListFiles(var A: TGFiles;settings:Tlistsettings;parentid:string='root';customfields:string='*');
194 | procedure FillGFileMetadata(var A:TGFile;settings:Tlistsettings);
195 |
196 | //function GetRootFolderId:string;
197 | function AboutGdrive(version:apiver):TGoogleDriveInformation;
198 |
199 | published
200 |
201 | end;
202 |
203 |
204 | implementation
205 |
206 |
207 | Procedure TGoogleDrive.ClearAllCustomProperties;
208 | begin
209 | setlength(CustomBodyProperties,0);
210 | setlength(CustomQueryProperties,0);
211 | end;
212 |
213 | Procedure TGoogleDrive.AddCustomProperty(var customproperty:TCustomproperties;cname,cvalue:string; PropAs : TCustomPropertyAs = aselse);
214 | var i : integer;
215 | begin
216 |
217 | i:=length(CustomProperty);
218 | Setlength(CustomProperty, i + 1);
219 |
220 | with CustomProperty[i] do
221 | begin
222 | name:=cname;
223 | value:=cvalue;
224 | if (PropAs = asstring) then value := '"' + value + '"';
225 | end
226 | end;
227 |
228 | procedure TGoogleDrive.UpStatus(Sender: TObject; Reason: THookSocketReason;
229 | const Value: string);
230 | begin
231 | if Reason = HR_WriteCount then
232 | begin
233 | Progress.StepBy(StrToIntDef(Value, 0));
234 | Application.ProcessMessages;
235 | end;
236 | end;
237 |
238 | function TGoogleDrive.UploadResumableFile(const URL: string;
239 | const Data: TStream): string;
240 | const
241 | MaxChunk = 40 * 256 * 1024; // ALWAYS chunks of 256KB
242 | var
243 | HTTP: THTTPSend;
244 | s: string;
245 | i: integer;
246 | From, Size: integer;
247 | Tries, PrevFrom: integer;
248 | begin
249 | Result := '';
250 | HTTP := THTTPSend.Create;
251 | try
252 | // Always check if there already was aborted upload (is easiest)
253 | HTTP.Headers.Add('Content-Length: 0');
254 | HTTP.Headers.Add('Content-Range: bytes */*');
255 |
256 | if not HTTP.HTTPMethod('PUT', URL) then exit;
257 | Result := 'pre - ' + #13 + HTTP.Headers.Text + #13 + #13 + HTTP.ResultString;
258 | From := 0;
259 | if HTTP.ResultCode in [200, 201] then
260 | begin
261 | Result := '200 already uploaded completely';
262 | exit;
263 | end;
264 | if HTTP.ResultCode = 308 then // Resume Incomplete
265 | begin
266 | for i := 0 to HTTP.Headers.Count - 1 do
267 | begin
268 | if Pos('Range: bytes=0-', HTTP.Headers.Strings[i]) > 0 then
269 | begin
270 | s := StringReplace(HTTP.Headers.Strings[i], 'Range: bytes=0-', '', []);
271 | From := StrToIntDef(s, -1) + 1; // from 0 or max_range + 1
272 | break;
273 | end;
274 | end;
275 | end;
276 | if not HTTP.ResultCode in [200, 201, 308] then
277 | exit;
278 |
279 | Tries := 0;
280 | PrevFrom := From;
281 | Progress.Min := 0;
282 | Progress.Max := Data.Size - 1;
283 | HTTP.Sock.OnStatus := @UpStatus;
284 | repeat
285 |
286 | Progress.Position := From;
287 |
288 | HTTP.Document.Clear;
289 | HTTP.Headers.Clear;
290 |
291 | // We need to resune upload from position "from"
292 | Data.Position := From;
293 | Size := Data.Size - From;
294 | if Size > MaxChunk then
295 | Size := MaxChunk;
296 | HTTP.Document.CopyFrom(Data, Size);
297 | HTTP.Headers.Add(Format('Content-Range: bytes %d-%d/%d',
298 | [From, From + Size - 1, Data.Size]));
299 | HTTP.MimeType := '';
300 | LogMemo.Lines.Add(HTTP.Headers.Text);
301 | if not HTTP.HTTPMethod('PUT', URL) then exit;
302 |
303 | Result := HTTP.Headers.Text + #13 + #13 + HTTP.ResultString;
304 | // Mainform.Memo2.Lines.Add(Result);
305 |
306 | if HTTP.ResultCode in [200, 201] then
307 | Result := '200 Upload complete';
308 | if HTTP.ResultCode = 308 then // Resume Incomplete
309 | begin
310 | for i := 0 to HTTP.Headers.Count - 1 do
311 | begin
312 | if Pos('Range: bytes=0-', HTTP.Headers.Strings[i]) > 0 then
313 | begin
314 | s := StringReplace(HTTP.Headers.Strings[i], 'Range: bytes=0-', '', []);
315 | PrevFrom := From;
316 | From := StrToIntDef(s, -1) + 1; // from 0 or max_range + 1
317 | break;
318 | end;
319 | end;
320 | end;
321 |
322 | // no 308 with actual transfer is received, increase tries
323 | if PrevFrom = From then
324 | Inc(Tries);
325 |
326 | until (HTTP.ResultCode in [200, 201]) or (Tries > 1);
327 |
328 | finally
329 | HTTP.Free;
330 | end;
331 |
332 | end;
333 |
334 |
335 | Function TGoogleDrive.ExtractBodyProperties:string;
336 | var i : integer;
337 | begin
338 | result:= '{' + CRLF + '}';
339 | if length(CustomBodyProperties)>0 then
340 | begin
341 | result := '{' + CRLF;
342 | for i:=0 to length(CustomBodyProperties)-1 do
343 | begin;
344 | result := result + '"' + CustomBodyProperties[i].name + '": ';
345 | result := result + CustomBodyProperties[i].value;
346 | if i0 then
358 | begin
359 | result := '?';
360 | for i:=0 to length(CustomQueryProperties)-1 do
361 | begin
362 | result := result + CustomQueryProperties[i].name + '=' + CustomQueryProperties[i].value;
363 | if i '' then
435 | begin
436 | Method := 'PATCH';
437 | URLM := URL + '/' + fileid;
438 | rev:='originalFilename';
439 | end
440 | else
441 | begin
442 | Method := 'POST';
443 | URLM := URL;
444 | rev:='name';
445 | end;
446 |
447 | ClearAllCustomProperties;
448 | AddCustomProperty(CustomBodyProperties,rev,ExtractFileName(FileN),asstring);
449 |
450 | if (Renamefile in settings) and (fileid <> '') then
451 | AddCustomProperty(CustomBodyProperties,'name',ExtractFileName(FileN),asstring);
452 |
453 | AddCustomProperty(CustomBodyProperties,'description',Description,asstring);
454 |
455 | s := ExtractBodyProperties;
456 |
457 | HTTP := THTTPSend.Create;
458 | try
459 | HTTP.MimeType := 'application/json; charset=UTF-8';
460 |
461 | WriteStrToStream(HTTP.Document, ansistring(s));
462 |
463 | HTTP.Headers.Add(Format('X-Upload-Content-Length: %d', [Data.Size]));
464 | HTTP.Headers.Add('Authorization: Bearer ' + auth);
465 |
466 | AddCustomProperty(CustomQueryProperties,'uploadType','resumable');
467 | if (KeepForever in settings) then
468 | AddCustomProperty(CustomQueryProperties,'keepRevisionForever','true');
469 |
470 | parameters := ExtractQueryProperties;
471 |
472 | LogMemo.Lines.Add(s + chr(13) + URLM + '[' + parameters + ']');
473 |
474 | if not HTTP.HTTPMethod(Method, URLM + parameters) then
475 | begin
476 | LogMemo.Lines.Add('Error retrieving URI');
477 | exit;
478 | end;
479 | Result := HTTP.ResultString; // for any errors
480 |
481 | for i := 0 to HTTP.Headers.Count - 1 do
482 | begin
483 | if Pos('Location: ', HTTP.Headers.Strings[i]) > 0 then
484 | begin
485 | Result := StringReplace(HTTP.Headers.Strings[i], 'Location: ', '', []);
486 | break;
487 | end;
488 | end;
489 | finally
490 | HTTP.Free;
491 | end;
492 | end;
493 |
494 |
495 | function TGoogleDrive.DownloadResumableFile(JFile: TGFile; TargetFile: string; revisionid: string = ''; exportmimetype : string = ''): boolean;
496 | const
497 | MaxChunk = 1024 * 1024;// 40 * 256 * 1024;
498 | var
499 | HTTPGetResult: boolean;
500 | URL, URLM: string;
501 | from,size: integer;
502 | Stream: TFileStream;
503 | resume: boolean;
504 | begin
505 |
506 | CancelCurrent:= False;
507 | Result := False;
508 | resume:= false;
509 |
510 | if FileExists(TargetFile) then
511 | begin
512 | Stream:=TFileStream.Create(TargetFile, fmOpenReadWrite);
513 | from:= Stream.size;
514 | resume:= true;
515 | end
516 | else
517 | begin
518 | Stream:=TFileStream.Create(TargetFile, fmCreate);
519 | from := 0;
520 | end;
521 |
522 | size := strtoint64(JFile.size);
523 |
524 | if gOAuth2.EMail = '' then exit;
525 |
526 | DownHTTP := THTTPSend.Create;
527 | Progress.Min := 0;
528 | Progress.Max := size;
529 | Progress.Position:= from;
530 | Bytes := 0;
531 |
532 | MaxBytes := -1;
533 |
534 | if not resume then
535 | LogMemo.Lines.Add('Downloading file...')
536 | else
537 | LogMemo.Lines.Add('Resuming file...');
538 |
539 | try
540 | repeat
541 | DownHTTP.Sock.OnStatus := @DownStatus;
542 | Stream.Seek(0,soEnd);
543 | URL := MetadataURL + '/' + JFile.fileid;
544 | ClearAllCustomProperties;
545 |
546 | if revisionid <> '' then URL := URL + '/revisions/' + revisionid;
547 |
548 | if exportmimetype <> '' then
549 | begin
550 | URL := URL + '/export';
551 | AddCustomProperty(CustomQueryProperties, 'mimeType',exportmimetype);
552 | end
553 | else AddCustomProperty(CustomQueryProperties, 'alt','media');
554 |
555 | DownHTTP.Clear;
556 | DownHTTP.Headers.Add('Authorization: Bearer ' + gOAuth2.Access_token);
557 | DownHTTP.Headers.Add(format('Range: bytes=%d-%d',[from,from+maxchunk]));
558 |
559 | Result := DownHTTP.HTTPMethod('GET', URL + ExtractQueryproperties);
560 |
561 | if (DownHTTP.ResultCode >= 100) and (DownHTTP.ResultCode <= 299) then
562 | begin
563 | Stream.CopyFrom(DownHTTP.Document, DownHTTP.Document.Size);
564 |
565 | LogMemo.Lines.Add('Download OK [' + IntToStr(DownHTTP.ResultCode) + ' - Range ' + inttostr(from) + ' to ' + inttostr(from+DownHTTP.Document.Size) +']');
566 | // LogMemo.Lines.Add(DownHTTP.Headers.Text);
567 | inc(from,DownHTTP.Document.Size);
568 | end
569 | else
570 | begin
571 | CancelCurrent:=true;
572 | LogMemo.Lines.Add('Error downloading file [' + IntToStr(DownHTTP.ResultCode) + ']');
573 | end;
574 |
575 |
576 | Application.processmessages;
577 | until (from >= size) or (CancelCurrent);
578 | Result := True;
579 |
580 | finally
581 | DownHTTP.Free;
582 | Stream.Free;
583 |
584 | if (JFile.md5Checksum<> '') and (JFile.md5Checksum=md5print(md5file(TargetFile))) then
585 | LogMemo.Lines.Add('Download OK - checkSum OK') else
586 | LogMemo.Lines.Add('Download OK - checkSum is not correct !!!');
587 |
588 | end;
589 | end;
590 |
591 |
592 | function TGoogleDrive.DownloadFile(id, TargetFile: string; revisionid: string = ''; exportmimetype : string = ''): boolean;
593 | var
594 | HTTPGetResult: boolean;
595 | URL, URLM: string;
596 | begin
597 | Result := False;
598 | if gOAuth2.EMail = '' then exit;
599 | Bytes := 0;
600 | MaxBytes := -1;
601 | DownHTTP := THTTPSend.Create;
602 | try
603 | Progress.Min := 0;
604 | Progress.Max := 100;
605 | // DownHTTP.Sock.OnStatus := @DownStatus;
606 | LogMemo.Lines.Add('Downloading file...');
607 |
608 | URL := MetadataURL + '/' + id;
609 |
610 | ClearAllCustomProperties;
611 |
612 | if revisionid <> '' then URL := URL + '/revisions/' + revisionid;
613 |
614 | if exportmimetype <> '' then
615 | begin
616 | URL := URL + '/export';
617 | AddCustomProperty(CustomQueryProperties, 'mimeType',exportmimetype);
618 | end
619 | else AddCustomProperty(CustomQueryProperties, 'alt','media');
620 |
621 | DownHTTP.Headers.Add('Authorization: Bearer ' + gOAuth2.Access_token);
622 |
623 | Result := DownHTTP.HTTPMethod('GET', URL + ExtractQueryproperties);
624 |
625 | if (DownHTTP.ResultCode >= 100) and (DownHTTP.ResultCode <= 299) then
626 | begin
627 | DownHTTP.Document.SaveToFile(TargetFile);
628 | LogMemo.Lines.Add('Download OK [' + IntToStr(DownHTTP.ResultCode) + ']');
629 | Result := True;
630 | end
631 | else
632 | begin
633 | LogMemo.Lines.Add('Error downloading file [' + IntToStr(DownHTTP.ResultCode) + ']');
634 | end;
635 |
636 | finally
637 | DownHTTP.Free;
638 | end;
639 | end;
640 |
641 | procedure TGoogleDrive.DownStatus(Sender: TObject; Reason: THookSocketReason; const Value: string);
642 | var
643 | V, currentHeader: string;
644 | i: integer;
645 | pct: integer;
646 | begin
647 | if (MaxBytes = -1) then
648 | begin
649 | for i := 0 to DownHTTP.Headers.Count - 1 do
650 | begin
651 | currentHeader := DownHTTP.Headers[i];
652 | MaxBytes := GetSizeFromHeader(currentHeader);
653 | if MaxBytes <> -1 then break;
654 | end;
655 | end;
656 |
657 | V := GetEnumName(TypeInfo(THookSocketReason), integer(Reason)) + ' ' + Value;
658 |
659 | if Reason = THookSocketReason.HR_ReadCount then
660 | begin
661 | Bytes := Bytes + StrToInt(Value);
662 | pct := round(Bytes / maxbytes * 100);
663 | Progress.Position := progress.position + StrToInt(Value);//pct;
664 | Application.ProcessMessages;
665 | end;
666 |
667 | end;
668 |
669 | function TGoogleDrive.GetSizeFromHeader(Header: string): integer;
670 | var
671 | item: TStringList;
672 | begin
673 | Result := -1;
674 | if Pos('Content-Length:', Header) <> 0 then
675 | begin
676 | item := TStringList.Create();
677 | try
678 | item.Delimiter := ':';
679 | item.StrictDelimiter := True;
680 | item.DelimitedText := Header;
681 | if item.Count = 2 then
682 | begin
683 | Result := StrToInt(Trim(item[1]));
684 | end;
685 | finally
686 | item.Free;
687 | end;
688 | end;
689 | end;
690 |
691 | constructor TGoogleDrive.Create(AOwner: TComponent; client_id, client_secret: string);
692 | begin
693 | inherited Create(AOwner);
694 | FieldDefs.Clear;
695 | //FieldDefs.Add('Boolean', ftBoolean, 0, False);
696 | //FieldDefs.Add('Integer', ftInteger, 0, False);
697 | //FieldDefs.Add('SmallInt', ftSmallInt, 0, False);
698 | //FieldDefs.Add('Float', ftFloat, 0, False);
699 | //FieldDefs.Add('String', ftString, 30, False);
700 | //FieldDefs.Add('Time', ftTime, 0, False);
701 | //FieldDefs.Add('Date', ftDate, 0, False);
702 | //FieldDefs.Add('DateTime', ftDateTime, 0, False);
703 | FieldDefs.Add('title', ftString, 255, False);
704 | FieldDefs.Add('fileId', ftString, 255, False);
705 | FieldDefs.Add('description', ftString, 255, False);
706 | FieldDefs.Add('created', ftString, 255, False);
707 | FieldDefs.Add('modified', ftString, 255, False);
708 | FieldDefs.Add('downloadurl', ftString, 255, False);
709 | FieldDefs.Add('filename', ftString, 255, False);
710 | FieldDefs.Add('md5', ftString, 255, False);
711 | FieldDefs.Add('filesize', ftString, 20, False);
712 | FieldDefs.Add('IsFolder', ftBoolean, 0, False);
713 | FieldDefs.Add('mimeType', ftString, 255, False);
714 | FieldDefs.Add('iconLink', ftString, 255, False);
715 | CreateTable;
716 |
717 | gOAuth2 := TGoogleOAuth2.Create(client_id, client_secret);
718 |
719 | end;
720 |
721 | destructor TGoogleDrive.Destroy;
722 | begin
723 | gOAuth2.Free;
724 | inherited Destroy;
725 | end;
726 |
727 |
728 | function RetrieveJSONValueInt64(JSON: TJSONData; Value: string): int64;
729 | var
730 | D: TJSONData;
731 | begin
732 | Result := 0;
733 | if Assigned(JSON) then
734 | begin
735 | D := JSON.FindPath(Value);
736 | if assigned(D) then
737 | Result := D.AsInt64;
738 | end;
739 | end;
740 |
741 | function RetrieveJSONValue(JSON: TJSONData; Value: string): string;
742 | var
743 | D: TJSONData;
744 | begin
745 | Result := '';
746 | if Assigned(JSON) then
747 | begin
748 | D := JSON.FindPath(Value);
749 | if assigned(D) then
750 | Result := D.AsString;
751 | end;
752 | end;
753 |
754 | procedure TGoogleDrive.Populate(aFilter: string = '');
755 | var
756 | Response: TStringList;
757 | URL: string;
758 | Params: string;
759 | P: TJSONParser;
760 | I: integer;
761 | J, D, E: TJSONData;
762 | begin
763 | (*
764 | {
765 | "kind": "drive#fileList",
766 | "etag": etag,
767 | "selfLink": string,
768 | "nextPageToken": string,
769 | "nextLink": string,
770 | "items": [ files Resource ]
771 | }
772 |
773 | {
774 | "kind": "drive#file",
775 | "id": string,
776 | "etag": etag,
777 | "selfLink": string,
778 | "webContentLink": string,
779 | "webViewLink": string,
780 | "alternateLink": string,
781 | "embedLink": string,
782 | "openWithLinks": {
783 | (key): string
784 | },
785 | "defaultOpenWithLink": string,
786 | "iconLink": string,
787 | "thumbnailLink": string,
788 | "thumbnail": {
789 | "image": bytes,
790 | "mimeType": string
791 | },
792 | "title": string,
793 | "mimeType": string,
794 | "description": string,
795 | "labels": {
796 | "starred": boolean,
797 | "hidden": boolean,
798 | "trashed": boolean,
799 | "restricted": boolean,
800 | "viewed": boolean
801 | },
802 | "createdDate": datetime,
803 | "modifiedDate": datetime,
804 | "modifiedByMeDate": datetime,
805 | "lastViewedByMeDate": datetime,
806 | "markedViewedByMeDate": datetime,
807 | "sharedWithMeDate": datetime,
808 | "version": long,
809 | "sharingUser": {
810 | "kind": "drive#user",
811 | "displayName": string,
812 | "picture": {
813 | "url": string
814 | },
815 | "isAuthenticatedUser": boolean,
816 | "permissionId": string,
817 | "emailAddress": string
818 | },
819 | "parents": [
820 | parents Resource
821 | ],
822 | "downloadUrl": string,
823 | "downloadUrl": string,
824 | "exportLinks": {
825 | (key): string
826 | },
827 | "indexableText": {
828 | "text": string
829 | },
830 | "userPermission": permissions Resource,
831 | "permissions": [
832 | permissions Resource
833 | ],
834 | "originalFilename": string,
835 | "fileExtension": string,
836 | "fullFileExtension": string,
837 | "md5Checksum": string,
838 | "fileSize": long,
839 | "quotaBytesUsed": long,
840 | "ownerNames": [
841 | string
842 | ],
843 | "owners": [
844 | {
845 | "kind": "drive#user",
846 | "displayName": string,
847 | "picture": {
848 | "url": string
849 | },
850 | "isAuthenticatedUser": boolean,
851 | "permissionId": string,
852 | "emailAddress": string
853 | }
854 | ],
855 | "lastModifyingUserName": string,
856 | "lastModifyingUser": {
857 | "kind": "drive#user",
858 | "displayName": string,
859 | "picture": {
860 | "url": string
861 | },
862 | "isAuthenticatedUser": boolean,
863 | "permissionId": string,
864 | "emailAddress": string
865 | },
866 | "ownedByMe": boolean,
867 | "editable": boolean,
868 | "canComment": boolean,
869 | "canReadRevisions": boolean,
870 | "shareable": boolean,
871 | "copyable": boolean,
872 | "writersCanShare": boolean,
873 | "shared": boolean,
874 | "explicitlyTrashed": boolean,
875 | "appDataContents": boolean,
876 | "headRevisionId": string,
877 | "properties": [
878 | properties Resource
879 | ],
880 | "folderColorRgb": string,
881 | "imageMediaMetadata": {
882 | "width": integer,
883 | "height": integer,
884 | "rotation": integer,
885 | "location": {
886 | "latitude": double,
887 | "longitude": double,
888 | "altitude": double
889 | },
890 | "date": string,
891 | "cameraMake": string,
892 | "cameraModel": string,
893 | "exposureTime": float,
894 | "aperture": float,
895 | "flashUsed": boolean,
896 | "focalLength": float,
897 | "isoSpeed": integer,
898 | "meteringMode": string,
899 | "sensor": string,
900 | "exposureMode": string,
901 | "colorSpace": string,
902 | "whiteBalance": string,
903 | "exposureBias": float,
904 | "maxApertureValue": float,
905 | "subjectDistance": integer,
906 | "lens": string
907 | },
908 | "videoMediaMetadata": {
909 | "width": integer,
910 | "height": integer,
911 | "durationMillis": long
912 | },
913 | "spaces": [
914 | string
915 | ],
916 | "isAppAuthorized": boolean
917 | }
918 |
919 |
920 |
921 |
922 | *)
923 | Response := TStringList.Create;
924 | Self.DisableControls;
925 | try
926 |
927 | if gOAuth2.EMail = '' then
928 | exit;
929 |
930 | // https://developers.google.com/drive/v2/reference/files/list
931 | gOAuth2.LogLine('Retrieving filelist ' + gOAuth2.EMail);
932 | URL := 'https://www.googleapis.com/drive/v2/files';
933 | Params := 'access_token=' + gOAuth2.Access_token;
934 | Params := Params + '&maxResults=1000';
935 | Params := Params + '&orderBy=folder,modifiedDate%20desc,title';
936 | if HttpGetText(URL + '?' + Params, Response) then
937 | begin
938 | gOAuth2.DebugLine(Response.Text);
939 | Self.Clear(False); // remove all records
940 |
941 | P := TJSONParser.Create(Response.Text);
942 | try
943 | J := P.Parse;
944 | if Assigned(J) then
945 | begin
946 |
947 | D := J.FindPath('error');
948 | if assigned(D) then
949 | begin
950 | LastErrorCode := RetrieveJSONValue(D, 'code');
951 | LastErrorMessage := RetrieveJSONValue(D, 'message');
952 | gOAuth2.LogLine(format('Error %s: %s',
953 | [LastErrorCode, LastErrorMessage]));
954 | exit;
955 | end;
956 |
957 | gOAuth2.LogLine('Busy filling dataset');
958 |
959 | D := J.FindPath('items');
960 | gOAuth2.DebugLine(format('%d items received', [D.Count]));
961 | for I := 0 to D.Count - 1 do
962 | begin
963 | Append;
964 | // 2015-02-10T10:42:49.297Z
965 | // 2012-05-18T15:45:00+02:00
966 | FieldByName('title').AsString := RetrieveJSONValue(D.Items[I], 'title');
967 | FieldByName('fileId').AsString := RetrieveJSONValue(D.Items[I], 'id');
968 | FieldByName('description').AsString := RetrieveJSONValue(D.Items[I], 'description');
969 | FieldByName('created').AsString := RetrieveJSONValue(D.Items[I], 'createdDate');
970 | FieldByName('modified').AsString := RetrieveJSONValue(D.Items[I], 'modifiedDate');
971 | FieldByName('downloadurl').AsString := RetrieveJSONValue(D.Items[I], 'downloadUrl');
972 | FieldByName('filename').AsString := RetrieveJSONValue(D.Items[I], 'originalFilename');
973 | FieldByName('md5').AsString := RetrieveJSONValue(D.Items[I], 'md5Checksum');
974 | FieldByName('filesize').AsString := RetrieveJSONValue(D.Items[I], 'fileSize');
975 | FieldByName('mimeType').AsString := RetrieveJSONValue(D.Items[I], 'mimeType');
976 | FieldByName('iconLink').AsString := RetrieveJSONValue(D.Items[I], 'iconLink');
977 | FieldByName('IsFolder').AsBoolean := FieldByName('mimeType').AsString = 'application/vnd.google-apps.folder';
978 | Self.Post;
979 | Application.ProcessMessages;
980 |
981 | end;
982 |
983 | gOAuth2.LogLine(format('%d items stored', [Self.RecordCount]));
984 |
985 | gOAuth2.LogLine('Done filling dataset');
986 |
987 | end;
988 | finally
989 | if assigned(J) then
990 | J.Free;
991 | P.Free;
992 | end;
993 |
994 | end;
995 |
996 | finally
997 | Response.Free;
998 | Self.EnableControls;
999 | end;
1000 |
1001 | end;
1002 |
1003 |
1004 |
1005 | function TGoogleDrive.ParseMetadata(A:TJSONData;settings:TlistSettings):TGFile;
1006 | var F: TJSONData;
1007 | var K: integer;
1008 | begin
1009 |
1010 | with result do
1011 | begin
1012 |
1013 | fileid := RetrieveJSONValue(A, 'id');
1014 | name := RetrieveJSONValue(A, 'name');
1015 | mimeType := RetrieveJSONValue(A, 'mimeType');
1016 | description := RetrieveJSONValue(A, 'description');
1017 | createdTime := RetrieveJSONValue(A, 'createdTime');
1018 | modifiedTime := RetrieveJSONValue(A, 'modifiedTime');
1019 | downloadUrl := RetrieveJSONValue(A, 'downloadUrl');
1020 | originalFilename := RetrieveJSONValue(A, 'originalFilename');
1021 | md5Checksum := RetrieveJSONValue(A, 'md5Checksum');
1022 | size := RetrieveJSONValue(A, 'size');
1023 | iconLink := RetrieveJSONValue(A, 'iconLink');
1024 | isFolder := mimeType = 'application/vnd.google-apps.folder';
1025 | trashed := lowercase(RetrieveJSONValue(A, 'trashed'))='true';
1026 | headRevisionId := RetrieveJSONValue(A, 'headRevisionId');
1027 |
1028 | if (listrevisions in settings) and not isFolder then revisions := GetRevisions(fileid);
1029 |
1030 | // get parents
1031 | if (listparents in settings) then
1032 | begin;
1033 | setlength(parents,0);
1034 | F := A.FindPath('parents');
1035 | if not assigned(F) then
1036 | begin
1037 | // root case
1038 | setlength(parents,1);
1039 | parents[0].id:='root';
1040 | end
1041 | else
1042 | for K:=0 to F.Count-1 do
1043 | begin
1044 | setlength(parents,K+1);
1045 | with parents[K] do id:= (F.Items[K]).AsString;
1046 | end;
1047 | end;
1048 | end;
1049 | end;
1050 |
1051 | function TGoogleDrive.GetGFileMetadata(id:string;settings:TListSettings;customfields:string='*'):TGFile;
1052 | var
1053 | Response: TStringList;
1054 | URL: string;
1055 | Params: string;
1056 | P: TJSONParser;
1057 | I, K: integer;
1058 | A, J, D, E, F: TJSONData;
1059 | HTTP:THTTPSend;
1060 | begin
1061 | Response := TStringList.Create;
1062 |
1063 | result:=default(TGFile);
1064 | with result do begin
1065 | setlength(parents,1);
1066 | parents[0].id:='';
1067 | end;
1068 |
1069 | if gOAuth2.EMail = '' then exit;
1070 |
1071 | gOAuth2.LogLine('Retrieving metadata ' + gOAuth2.EMail);
1072 | gOAuth2.LogLine('Busy...');
1073 |
1074 | URL := 'https://www.googleapis.com/drive/v3/files/'+id;
1075 | Params := 'access_token=' + gOAuth2.Access_token;
1076 | HTTP:=THTTPSend.Create;
1077 | if HTTP.HTTPMethod('GET',URL + '?' + Params+'&fields='+customfields) then//HttpGetText(URL + '?' + Params+'&fields='+customfields, Response) then
1078 | begin
1079 |
1080 | if HTTP.ResultCode=401 then begin;
1081 | gOAuth2.LogLine('Session expired, please connect again');
1082 |
1083 | end
1084 | else
1085 | begin
1086 | Response.LoadFromStream(HTTP.Document);
1087 | gOauth2.logline(URL + '?' + Params+'&fields='+customfields);
1088 | P := TJSONParser.Create(Response.Text);
1089 | try
1090 | J := P.Parse;
1091 |
1092 | if Assigned(J) then
1093 | begin
1094 |
1095 | A := J.FindPath('error');
1096 | if assigned(A) then
1097 | begin
1098 | LastErrorCode := RetrieveJSONValue(A, 'code');
1099 | LastErrorMessage := RetrieveJSONValue(A, 'message');
1100 | gOAuth2.LogLine(format('Error %s: %s',
1101 | [LastErrorCode, LastErrorMessage]));
1102 | exit;
1103 | end;
1104 |
1105 | A := J;
1106 | Result:=ParseMetaData(A,settings);
1107 |
1108 | end;
1109 |
1110 | finally
1111 | if assigned(J) then
1112 | J.Free;
1113 | P.Free;
1114 | end;
1115 | end;
1116 |
1117 | Response.Free;
1118 |
1119 | end;
1120 | HTTP.Free;
1121 | end;
1122 |
1123 |
1124 | procedure TGoogleDrive.FillGFileMetadata(var A:TGFile;settings:Tlistsettings);
1125 | begin
1126 | if A.fileid='' then exit;
1127 | A:=GetGFileMetadata(A.fileid,settings);
1128 | end;
1129 |
1130 | procedure TGoogleDrive.ListFiles(var A: TGFiles;settings:Tlistsettings;parentid:string='root';customfields:string='*');
1131 | var
1132 | Response: TStringList;
1133 | URL: string;
1134 | Params, pageToken: string;
1135 | P: TJSONParser;
1136 | I, K: integer;
1137 | J, D, E, F: TJSONData;
1138 | HTTP:THTTPSend;
1139 | folderid,foldername:string;
1140 | prevfolder:TGFile;
1141 | begin
1142 | Response := TStringList.Create;
1143 |
1144 | Setlength(A,0);
1145 |
1146 | if showpreviousfolder in settings then begin
1147 | GOauth2.LogLine('Retrieving parent''s informations');
1148 | PrevFolder:=GetGFileMetadata(parentid,[listparents],'name,parents');
1149 | folderid:=PrevFolder.parents[0].id;
1150 | foldername:=PrevFolder.name;
1151 |
1152 | if folderid<>'root' then
1153 | begin;
1154 | SetLength(A, 1);
1155 | with A[0] do
1156 | begin
1157 | fileid:=folderid;
1158 | name:=''+foldername+' : Double click here to go back';
1159 | iconLink:='https://ssl.gstatic.com/docs/doclist/images/icon_11_collection_list_1.png';
1160 | mimeType:='application/vnd.google-apps.folder';
1161 | end;
1162 | end;
1163 | end;
1164 |
1165 | currentFolder:=parentid;
1166 | pageToken:='';
1167 | K:=0;
1168 | try
1169 |
1170 | if gOAuth2.EMail = '' then exit;
1171 |
1172 | gOAuth2.LogLine('Retrieving filelist ' + gOAuth2.EMail);
1173 | gOAuth2.LogLine('Busy...');
1174 |
1175 | if (customfields<>'') and (customfields<> '*') then
1176 | customfields := 'nextPageToken,files(' + customfields + ')';
1177 |
1178 | repeat;
1179 | URL := MetadataURL;//'https://www.googleapis.com/drive/v3/files';
1180 |
1181 | ClearAllCustomproperties;
1182 | AddCustomproperty(customQueryProperties,'access_token',gOAuth2.Access_token);
1183 | AddCustomproperty(customQueryProperties,'pageSize',IntToStr(MaxResults));
1184 | AddCustomproperty(customQueryProperties,'orderBy','folder,modifiedTime%20desc,name');
1185 | AddCustomproperty(customQueryProperties,'fields',customfields);
1186 |
1187 | // list specific parent folder
1188 | if parentid<>'' then AddCustomproperty(customQueryProperties,'q','"' +parentid + '"+in+parents'); //Params := Params + '&q="' + parentid + '"%20in%20parents';
1189 | if pageToken<>'' then AddCustomproperty(customQueryProperties,'pageToken',pageToken);//Params := Params + '&pageToken='+ pageToken;
1190 |
1191 | goauth2.LogLine(URL + ExtractQueryproperties);
1192 | HTTP:=THTTPSend.Create;
1193 | if HTTP.HTTPMethod('GET',URL + ExtractQueryproperties) then//HttpGetText(URL + '?' + Params, Response) then
1194 | begin
1195 | goauth2.Logline(inttostr(HTTP.ResultCode));
1196 | if HTTP.ResultCode=401 then
1197 | begin;
1198 | goauth2.Logline('Session expired');
1199 | end
1200 | else
1201 | begin
1202 | Response.LoadFromStream(HTTP.Document);
1203 | P := TJSONParser.Create(Response.Text);
1204 | try
1205 | J := P.Parse;
1206 | if Assigned(J) then
1207 | begin
1208 |
1209 | D := J.FindPath('error');
1210 | if assigned(D) then
1211 | begin
1212 | LastErrorCode := RetrieveJSONValue(D, 'code');
1213 | LastErrorMessage := RetrieveJSONValue(D, 'message');
1214 | gOAuth2.LogLine(format('Error %s: %s',
1215 | [LastErrorCode, LastErrorMessage]));
1216 | exit;
1217 | end;
1218 |
1219 |
1220 | gOAuth2.LogLine('Parsing...');
1221 | pageToken:=RetrieveJSONValue(J,'nextPageToken');
1222 | //gOAuth2.logline(pageToken);
1223 |
1224 | D := J.FindPath('files');
1225 | K:=length(A);
1226 | SetLength(A,K+D.Count);
1227 | gOAuth2.DebugLine(format('%d items received', [D.Count]));
1228 | for I := 0 to D.Count - 1 do
1229 | begin
1230 | A[K+I]:=ParseMetaData(D.Items[I],settings);
1231 | Application.ProcessMessages;
1232 | end;
1233 | gOAuth2.LogLine('Done');
1234 |
1235 | end;
1236 | finally
1237 | if assigned(J) then
1238 | J.Free;
1239 | P.Free;
1240 | end;
1241 | end;
1242 | end;
1243 |
1244 | HTTP.Free;
1245 |
1246 | until pageToken='';
1247 |
1248 | finally
1249 | Response.Free;
1250 | end;
1251 | end;
1252 |
1253 |
1254 | function TGoogleDrive.DeleteAllGFileRevisions(var A: TGFileRevisions): boolean;
1255 | var i: integer;
1256 | begin
1257 | Result := False;
1258 | for i := 0 to length(A) - 1 do if not (A[i].revisionid = '') then DeleteGFile(A[i].id, A[i].revisionid);
1259 | Result := True;
1260 | end;
1261 |
1262 |
1263 | function TGoogleDrive.DeleteGFileRevision(var A: TGFileRevision): boolean;
1264 | begin
1265 | Result := False;
1266 | if A.revisionid = '' then exit;
1267 | DeleteGFile(A.id, A.revisionid);
1268 | end;
1269 |
1270 |
1271 |
1272 | function TGoogleDrive.DeleteGFile(fileid:string; revisionid: string=''): boolean;
1273 | var
1274 | HTTP: THTTPSend;
1275 | Params: String;
1276 | begin
1277 | Result := False;
1278 | HTTP := THTTPSend.Create;
1279 | try
1280 | if gOAuth2.EMail = '' then
1281 | begin
1282 | logmemo.Lines.add('Not connected');
1283 | exit;
1284 | end;
1285 | Params := '';
1286 | if revisionid <> '' then
1287 | Params := '/revisions/' + revisionid;
1288 | HTTP.Headers.Add('Authorization: Bearer ' + gOAuth2.Access_token);
1289 | if not HTTP.HTTPMethod('DELETE', 'https://www.googleapis.com/drive/v3/files/' + fileId + Params) then exit;
1290 | if HTTP.ResultString = '' then Result := True;
1291 | logmemo.Lines.add(HTTP.Headers.Text + #13 + HTTP.ResultString);
1292 | finally
1293 | HTTP.Free;
1294 | end;
1295 |
1296 | end;
1297 |
1298 |
1299 |
1300 |
1301 | function TGoogleDrive.AboutGdrive(version:apiver):TGoogleDriveInformation;
1302 | var
1303 | HTTP: THTTPSend;
1304 | response:tstringlist;
1305 | P: TJSONParser;
1306 | I: integer;
1307 | J, D: TJSONData;
1308 | vx:string;
1309 | begin
1310 | HTTP := THTTPSend.Create;
1311 | try
1312 | if gOAuth2.EMail = '' then
1313 | begin
1314 | logmemo.Lines.add('Not connected');
1315 | exit;
1316 | end;
1317 |
1318 | case version of
1319 | v2:vx:='v2';
1320 | v3:vx:='v3';
1321 | end;
1322 |
1323 | logmemo.lines.add('Retrieving Google Drive Informations...');
1324 | if HTTP.HTTPMethod('GET','https://www.googleapis.com/drive/'+vx+'/about?access_token=' + gOAuth2.Access_token+'&fields=*') then
1325 | begin
1326 | response:=tstringlist.create;
1327 | response.LoadFromStream(HTTP.Document);
1328 | P := TJSONParser.Create(Response.Text);
1329 |
1330 | try
1331 | J := P.Parse;
1332 | Case version of
1333 |
1334 | v2:if Assigned(J) then
1335 | begin
1336 | with result do begin
1337 | rootFolderId:=RetrieveJSONValue(J, 'rootFolderId');
1338 | limit:=RetrieveJSONValueInt64(J, 'quotaBytesTotal');
1339 | usage:=RetrieveJSONValueInt64(J, 'quotaBytesUsedAggregate');
1340 | usageInDrive:=RetrieveJSONValueInt64(J, 'quotaBytesUsed');
1341 | usageInDriveTrash:=RetrieveJSONValueInt64(J, 'quotaBytesUsedInTrash');
1342 | end;
1343 | end;
1344 |
1345 | v3:if Assigned(J) then
1346 | begin
1347 | D:=J.FindPath('storageQuota');
1348 | if assigned(D) then
1349 | with result do begin
1350 | rootFolderId:='';
1351 | limit:=RetrieveJSONValueInt64(D, 'limit');
1352 | usage:=RetrieveJSONValueInt64(D, 'usage');
1353 | usageInDrive:=RetrieveJSONValueInt64(D, 'usageInDrive');
1354 | usageInDriveTrash:=RetrieveJSONValueInt64(D, 'usageInDriveTrash');
1355 | end;
1356 | end;
1357 |
1358 | end;
1359 |
1360 | finally
1361 | P.Free;
1362 | if assigned(J) then J.Free;
1363 | end;
1364 |
1365 | end;
1366 | finally
1367 | HTTP.Free;
1368 | Response.free;
1369 | end;
1370 | logmemo.lines.add('Done...');
1371 | end;
1372 |
1373 |
1374 | procedure TGoogleDrive.GetGFileRevisions(var A: TGFile);
1375 | begin
1376 | setlength(A.revisions, 0);
1377 | A.revisions := GetRevisions(A.fileid);
1378 | end;
1379 |
1380 | function TGoogleDrive.GetRevisions(fileid: string): TGFileRevisions;
1381 | var
1382 | Response: TStringList;
1383 | URL: string;
1384 | Params: string;
1385 | P: TJSONParser;
1386 | I: integer;
1387 | J, D, E: TJSONData;
1388 | F: TGFileRevisions;
1389 | begin
1390 | (*
1391 | {
1392 | "kind": "drive#revision",
1393 | "etag": etag,
1394 | "id": string,
1395 | "selfLink": string,
1396 | "mimeType": string,
1397 | "modifiedDate": datetime,
1398 | "pinned": boolean,
1399 | "published": boolean,
1400 | "publishedLink": string,
1401 | "publishAuto": boolean,
1402 | "publishedOutsideDomain": boolean,
1403 | "downloadUrl": string,
1404 | "exportLinks": {
1405 | (key): string
1406 | },
1407 | "lastModifyingUserName": string,
1408 | "lastModifyingUser": {
1409 | "kind": "drive#user",
1410 | "displayName": string,
1411 | "picture": {
1412 | "url": string
1413 | },
1414 | "isAuthenticatedUser": boolean,
1415 | "permissionId": string,
1416 | "emailAddress": string
1417 | },
1418 | "originalFilename": string,
1419 | "md5Checksum": string,
1420 | "fileSize": long
1421 | }
1422 | *)
1423 | SetLength(F, 0);
1424 |
1425 | Response := TStringList.Create;
1426 | try
1427 |
1428 | if gOAuth2.EMail = '' then
1429 | exit;
1430 |
1431 | // https://developers.google.com/drive/v2/reference/files/list
1432 | gOAuth2.LogLine('Retrieving revisions of the current file ' + fileid);
1433 | URL := 'https://www.googleapis.com/drive/v2/files/' + fileid + '/revisions';
1434 | Params := 'access_token=' + gOAuth2.Access_token;
1435 | if HttpGetText(URL + '?' + Params, Response) then
1436 | begin
1437 | gOAuth2.DebugLine(Response.Text);
1438 | P := TJSONParser.Create(Response.Text);
1439 | try
1440 | J := P.Parse;
1441 | if Assigned(J) then
1442 | begin
1443 |
1444 | D := J.FindPath('error');
1445 | if assigned(D) then
1446 | begin
1447 | LastErrorCode := RetrieveJSONValue(D, 'code');
1448 | LastErrorMessage := RetrieveJSONValue(D, 'message');
1449 | gOAuth2.LogLine(format('Error %s: %s',
1450 | [LastErrorCode, LastErrorMessage]));
1451 | exit;
1452 | end;
1453 |
1454 | //gOAuth2.LogLine('Busy retrieving file revisions');
1455 |
1456 | D := J.FindPath('items');
1457 | gOAuth2.DebugLine(format('%d revisions currently available', [D.Count]));
1458 | for I := 0 to D.Count - 1 do
1459 | begin
1460 | SetLength(F, length(F) + 1);
1461 |
1462 | with F[length(F) - 1] do
1463 | begin
1464 | id := fileid;
1465 | revisionid := RetrieveJSONValue(D.Items[I], 'id');
1466 | modifiedTime := RetrieveJSONValue(D.Items[I], 'modifiedTime');
1467 | mimetype := RetrieveJSONValue(D.Items[I], 'mimeType');
1468 | originalFileName := RetrieveJSONValue(D.Items[I], 'originalFilename');
1469 | size := RetrieveJSONValue(D.Items[I], 'size');
1470 | Application.ProcessMessages;
1471 | end;
1472 | end;
1473 |
1474 | gOAuth2.LogLine('Done');
1475 |
1476 | end;
1477 | Result := F;
1478 | finally
1479 | if assigned(J) then
1480 | J.Free;
1481 | P.Free;
1482 | end;
1483 |
1484 | end;
1485 |
1486 | finally
1487 | Response.Free;
1488 | end;
1489 |
1490 | end;
1491 |
1492 |
1493 |
1494 | procedure TGoogleDrive.CreateFolder(foldername: string; parentid: string = '');
1495 | var
1496 | HTTP: THTTPSend;
1497 | s: string;
1498 | begin
1499 | HTTP := THTTPSend.Create;
1500 | try
1501 | if foldername = '' then exit;
1502 | if gOAuth2.EMail = '' then
1503 | begin
1504 | logmemo.Lines.add('Not connected');
1505 | exit;
1506 | end;
1507 |
1508 | ClearAllCustomProperties;
1509 | AddCustomProperty(CustomBodyProperties,'name',foldername,asstring);
1510 |
1511 | if parentid <> '' then
1512 | AddCustomProperty(CustomBodyProperties,'parents', '[{"id":"' + parentid + '"}]');
1513 |
1514 | AddCustomProperty(CustomBodyProperties,'mimeType','application/vnd.google-apps.folder',asstring);
1515 |
1516 | s := ExtractBodyproperties;
1517 |
1518 | WriteStrToStream(HTTP.Document, ansistring(s));
1519 | logmemo.Lines.add(s);
1520 | HTTP.Headers.Add('Authorization: Bearer ' + gOAuth2.Access_token);
1521 | HTTP.MimeType := 'application/json; charset=UTF-8';
1522 | if not HTTP.HTTPMethod('POST', 'https://www.googleapis.com/drive/v3/files') then exit;
1523 | logmemo.Lines.add(HTTP.Headers.Text + #13 + HTTP.ResultString);
1524 | finally
1525 | HTTP.Free;
1526 | end;
1527 | end;
1528 |
1529 | end.
1530 |
--------------------------------------------------------------------------------
/google_oauth2.pas:
--------------------------------------------------------------------------------
1 | { google_oauth2
2 |
3 | Copyright (C) 2015-2015 Rik van Kekem (rvk)
4 |
5 | This library is free software; you can redistribute it and/or modify it
6 | under the terms of the GNU Library General Public License as published by
7 | the Free Software Foundation; either version 2 of the License, or (at your
8 | option) any later version with the following modification:
9 |
10 | As a special exception, the copyright holders of this library give you
11 | permission to link this library with independent modules to produce an
12 | executable, regardless of the license terms of these independent modules,and
13 | to copy and distribute the resulting executable under terms of your choice,
14 | provided that you also meet, for each linked independent module, the terms
15 | and conditions of the license of that module. An independent module is a
16 | module which is not derived from or based on this library. If you modify
17 | this library, you may extend this exception to your version of the library,
18 | but you are not obligated to do so. If you do not wish to do so, delete this
19 | exception statement from your version.
20 |
21 | This program is distributed in the hope that it will be useful, but WITHOUT
22 | ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
23 | FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
24 | for more details.
25 |
26 | You should have received a copy of the GNU Library General Public License
27 | along with this library; if not, write to the Free Software Foundation,
28 | Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
29 | }
30 |
31 | {
32 | Purpose:
33 | With this unit (class TGoogleOAuth2) you can get access to the Google apis
34 |
35 | https://developers.google.com/identity/protocols/OpenIDConnect#getcredentials
36 | https://developers.google.com/accounts/docs/OAuth2InstalledApp
37 | https://developers.google.com/oauthplayground/
38 | https://developers.google.com/google-apps/calendar/
39 | https://masashi-k.blogspot.nl/2013/06/sending-mail-with-gmail-using-xoauth2.html
40 | https://www.limilabs.com/blog/oauth2-gmail-imap-service-account
41 |
42 |
43 | 2022-01-11 use a local server instance to retrieve authorization code instead of IE browser
44 | 2022-01-11 UseBrowserTitle and ForceManualAuth removed
45 | 2016-12-12 delphi compatible
46 | 2016-12-12 using superobject for json
47 | 2015-07-08 usebrowsertitle to get the auth.code from the title-bar (which sometimes didn't work)
48 | 2015-07-08 implemented focemanualauth so you always need to enter auth.code manually
49 | 2015-07-07 some extra debug information
50 | 2015-07-07 initial getinformation only done when access_token is not empty
51 | 2015-07-07 extra variable Tokens_refreshed to indicate you need to save the tokens
52 | 2015-07-04 initial release
53 |
54 | }
55 | // todo: convert for delphi compatibility
56 | // todo: maybe make token_filename changable
57 | // todo: improve the documentation and comments
58 | // http://calebb.net/
59 |
60 | unit google_oauth2;
61 |
62 | {$IFDEF FPC}
63 | {$mode delphi}{$H+}
64 | {$ENDIF}
65 |
66 |
67 | interface
68 |
69 | uses
70 | Classes, StdCtrls, SysUtils {, fpjson, jsonparser};
71 |
72 | type
73 | GoogleScope = (goMail, goContacts, goCalendar, goDrive);
74 | GoogleScopeSet = set of GoogleScope;
75 |
76 | type
77 | TGoogleOAuth2 = class(TObject)
78 | private
79 | { private declarations }
80 | FClient_id: string;
81 | FClient_secret: string;
82 | FAuthorize_token: string;
83 | FRefresh_token: string;
84 | FAccess_token: string;
85 | FTokens_refreshed: boolean;
86 | FScopes: TStringList;
87 | FLastErrorCode: string;
88 | FLastErrorMessage: string;
89 | FFullname: string;
90 | FEMail: string;
91 | FLogMemo: TMemo;
92 | FDebugMemo: TMemo;
93 | private
94 | procedure LoadAccessRefreshTokens;
95 | procedure SaveAccessRefreshTokens;
96 | procedure GetAuthorize_token_interactive;
97 | procedure GetRefresh_token;
98 | procedure GetAccess_token;
99 | public
100 | { public declarations }
101 | constructor Create(client_id, client_secret: string); virtual;
102 | destructor Destroy; override;
103 | // function RetrieveJSONValue(JSON: TJSONData; Value: string): string;
104 |
105 | procedure GetAccess(Scopes: GoogleScopeSet = []; UseTokenFile: boolean = False);
106 | function GetXOAuth2Base64: string;
107 | procedure LogLine(Value: string);
108 | procedure DebugLine(Value: string);
109 |
110 | property Tokens_refreshed: boolean read FTokens_refreshed write FTokens_refreshed;
111 | property Authorize_token: string read FAuthorize_token write FAuthorize_token;
112 | property Refresh_token: string read FRefresh_token write FRefresh_token;
113 | property Access_token: string read FAccess_token write FAccess_token;
114 | property LastErrorCode: string read FLastErrorCode write FLastErrorCode;
115 | property LastErrorMessage: string read FLastErrorMessage write FLastErrorMessage;
116 | property Fullname: string read FFullname write FFullname;
117 | property EMail: string read FEMail write FEMail;
118 | property LogMemo: TMemo read FLogMemo write FLogMemo;
119 | property DebugMemo: TMemo read FDebugMemo write FDebugMemo;
120 |
121 | end;
122 |
123 | implementation
124 |
125 | {$IFNDEF FPC}
126 | {$DEFINE USE_SUPEROBJECT}
127 | {$ENDIF}
128 |
129 |
130 | uses
131 | synacode, synautil, httpsend, // for communication
132 | {$WARN UNIT_DEPRECATED OFF}
133 | ssl_openssl, // you need to include this one in your requirements
134 | {$WARN UNIT_DEPRECATED ON}
135 | comobj, // for ceating Browser-object
136 | // ActiveX, // CoInitialize
137 | Variants,
138 | Dialogs, // for inputbox
139 | Forms, // for Screen.Width/Height
140 | blcksock,
141 | // base64, // for the XOAuth2 token, we use synapse now
142 | {$IFDEF USE_SUPEROBJECT} superobject {$ELSE} fpjson, jsonparser {$ENDIF},
143 | Shellapi,
144 | Windows;
145 |
146 | const
147 | token_filename = 'tokens.dat';
148 | GetTokenUrl = 'https://accounts.google.com/o/oauth2/token';
149 | AuthorizationUrl = 'https://accounts.google.com/o/oauth2/auth';
150 | // RedirectUri = 'urn:ietf:wg:oauth:2.0:oob';
151 | RedirectUri = 'http://localhost:1500';
152 |
153 | {$IFNDEF FPC}
154 |
155 | // we re-declare this one with string so Delphi doesn't give hints about string-conversion
156 | function EncodeURLElement(const Value: string): string;
157 | begin
158 | Result := string(EncodeTriplet(ansistring(Value), '%', URLSpecialChar + URLFullSpecialChar));
159 | end;
160 |
161 | {$ENDIF}
162 |
163 | {$IFDEF USE_SUPEROBJECT}
164 |
165 |
166 | function RetrieveJSONValue(JSonString, Key: string; FromArray: string = ''; Index: integer = 0): string;
167 | var
168 | obj: ISuperObject;
169 | begin
170 | Result := '';
171 | obj := SO(JSonString);
172 | if FromArray = '' then
173 | begin
174 | // if obj.AsObject.Exists(Key) then Result := obj.S[Key];
175 | Result := obj.S[Key];
176 | end
177 | else
178 | begin
179 | if obj.AsObject.Exists(FromArray) then
180 | if obj.A[FromArray].O[Index].AsObject.Exists(Key) then
181 | Result := obj.A[FromArray].O[Index].S[Key];
182 | end;
183 | Result := AnsiDequotedStr(Result, '"');
184 | end;
185 |
186 | {$ELSE}
187 |
188 | function RetrieveJSONValue(JSonString, Key: string; FromArray: string = ''; Index: integer = 0): string;
189 | var
190 | P: TJSONParser;
191 | J, D, L: TJSONData;
192 | Key1, Key2: string;
193 | begin
194 | Result := '';
195 | Key1 := Key;
196 | Key2 := '';
197 | if Pos('.', Key1) > 0 then
198 | begin
199 | Key2 := Copy(Key1, Pos('.', Key1) + 1);
200 | Key1 := Copy(Key1, 1, Pos('.', Key1) - 1);
201 | end;
202 | P := TJSONParser.Create(JSonString);
203 | try
204 | J := P.Parse;
205 | if Assigned(J) then
206 | begin
207 | if FromArray <> '' then
208 | begin
209 | D := J.FindPath(FromArray);
210 | if Assigned(D) and (D.Count > 0) then
211 | begin
212 | D := D.Items[Index];
213 | L := D.FindPath(Key1);
214 | if assigned(L) then
215 | Result := L.AsString;
216 | end;
217 | end
218 | else
219 | begin
220 | if Key2 <> '' then
221 | begin
222 | D := J.FindPath(Key1);
223 | if Assigned(D) then
224 | begin
225 | L := D.FindPath(Key2);
226 | if assigned(L) then
227 | Result := L.AsString;
228 | end;
229 | end
230 | else
231 | begin
232 | D := J.FindPath(Key1);
233 | if Assigned(D) then
234 | Result := D.AsString;
235 | end;
236 | end;
237 | end;
238 | finally
239 | //if Assigned(L) then L.Free;
240 | //if Assigned(D) then D.Free;
241 | if Assigned(J) then J.Free;
242 | P.Free;
243 | end;
244 | end;
245 |
246 | {$ENDIF}
247 |
248 |
249 | constructor TGoogleOAuth2.Create(client_id, client_secret: string);
250 | begin
251 | inherited Create;
252 | FClient_id := client_id;
253 | FClient_secret := client_secret;
254 | FAuthorize_token := '';
255 | FRefresh_token := '';
256 | FAccess_token := '';
257 | FTokens_refreshed := False;
258 | FLastErrorCode := '';
259 | FLastErrorMessage := '';
260 | FFullname := '';
261 | FEMail := '';
262 | FLogMemo := nil;
263 | FDebugMemo := nil;
264 | FScopes := TStringList.Create;
265 | FScopes.Delimiter := ' ';
266 | FScopes.QuoteChar := ' ';
267 | end;
268 |
269 | destructor TGoogleOAuth2.Destroy;
270 | begin
271 | FScopes.Free;
272 | inherited Destroy;
273 | end;
274 |
275 | procedure TGoogleOAuth2.LogLine(Value: string);
276 | begin
277 | if LogMemo <> nil then
278 | LogMemo.Lines.Add(Value);
279 | DebugLine(Value);
280 | end;
281 |
282 | procedure TGoogleOAuth2.DebugLine(Value: string);
283 | begin
284 | {$IFDEF DEBUG}
285 | // Showmessage(Value);
286 | {$ENDIF}
287 | if DebugMemo <> nil then
288 | DebugMemo.Lines.Add(Value);
289 | end;
290 |
291 | procedure TGoogleOAuth2.GetAccess(Scopes: GoogleScopeSet = []; UseTokenFile: boolean = False);
292 |
293 | // tr '._-' '\n/+' | sed '2s|$|===|p;d' | base64 -D
294 |
295 | procedure GetInformation;
296 | var
297 | URL: string;
298 | Params: string;
299 | Response: TStringList;
300 | JSonStr: string;
301 | begin
302 | URL := 'https://www.googleapis.com/oauth2/v3/userinfo';
303 | Params := 'access_token=' + Access_token;
304 | Response := TStringList.Create;
305 | try
306 | if HttpGetText(URL + '?' + Params, Response) then
307 | begin
308 | JSonStr := Response.Text;
309 | DebugLine(JSonStr);
310 | LastErrorCode := RetrieveJSONValue(JSonStr, 'error.code');
311 | LastErrorMessage := RetrieveJSONValue(JSonStr, 'error.message');
312 | if LastErrorCode <> '' then
313 | LogLine(Format('Error in GetRefresh_token: %s - %s', [LastErrorCode, LastErrorMessage]));
314 |
315 | Fullname := RetrieveJSONValue(JSonStr, 'name');
316 | EMail := RetrieveJSONValue(JSonStr, 'email');
317 |
318 | end;
319 |
320 | finally
321 | Response.Free;
322 | end;
323 | end;
324 |
325 | procedure GetInformation_oud_viaGooglePlus_not_used_anymore;
326 | var
327 | URL: string;
328 | Params: string;
329 | Response: TStringList;
330 | JSonStr: string;
331 | begin
332 | URL := 'https://www.googleapis.com/plus/v1/people/me';
333 | Params := 'access_token=' + Access_token;
334 | Response := TStringList.Create;
335 | try
336 | if HttpGetText(URL + '?' + Params, Response) then
337 | begin
338 | JSonStr := Response.Text;
339 | LastErrorCode := RetrieveJSONValue(JSonStr, 'error.code');
340 | LastErrorMessage := RetrieveJSONValue(JSonStr, 'error.message');
341 | if LastErrorCode <> '' then
342 | LogLine(Format('Error in GetRefresh_token: %s - %s', [LastErrorCode, LastErrorMessage]));
343 |
344 | Fullname := RetrieveJSONValue(JSonStr, 'displayName');
345 | EMail := RetrieveJSONValue(JSonStr, 'value', 'emails', 0);
346 |
347 | end;
348 |
349 | finally
350 | Response.Free;
351 | end;
352 | end;
353 |
354 | begin
355 | if Scopes = [] then
356 | begin
357 | LogLine('No scope specified in GetAccess');
358 | end;
359 |
360 | FScopes.Add('profile'); // https://www.googleapis.com/auth/userinfo.profile
361 | FScopes.Add('email'); // https://www.googleapis.com/auth/userinfo.email
362 | // always use profile/email to find the full name and email
363 |
364 | // https://mail.google.com/
365 | // https://www.googleapis.com/auth/gmail.modify
366 | // https://www.googleapis.com/auth/gmail.compose
367 |
368 | // The scope for IMAP and SMTP access is https://mail.google.com/.
369 | // https://stackoverflow.com/questions/40881026/reduced-scope-for-gmail-imap-access
370 |
371 | if goMail in Scopes then FScopes.Add('https://mail.google.com/');
372 | // if goMail in Scopes then FScopes.Add('https://www.googleapis.com/auth/gmail.compose');
373 | if goContacts in Scopes then FScopes.Add('https://www.google.com/m8/feeds/');
374 | if goCalendar in Scopes then FScopes.Add('https://www.googleapis.com/auth/calendar');
375 | if goDrive in Scopes then FScopes.Add('https://www.googleapis.com/auth/drive');
376 |
377 | if UseTokenFile then LoadAccessRefreshTokens
378 | else
379 | begin
380 | // LogLine('If you had an access_token please set it before calling GetAccess');
381 | end;
382 |
383 | Fullname := '';
384 | EMail := '';
385 | if Access_token <> '' then
386 | begin
387 | LogLine('Getting account information');
388 | GetInformation;
389 | end;
390 | if (EMail = '') or (LastErrorCode <> '') or (Access_token = '') then
391 | begin
392 | if Access_token <> '' then
393 | begin
394 | LogLine(Format('Error: %s - %s', [LastErrorCode, LastErrorMessage]));
395 | LogLine(Format('Invalid access_token %s', [Access_token]));
396 | Access_token := ''; // <- invalidate
397 | end;
398 | GetAccess_token;
399 | if Access_token <> '' then
400 | begin
401 | LogLine('Getting account information');
402 | GetInformation;
403 | if (EMail <> '') then
404 | begin
405 | Tokens_refreshed := True; // and correct
406 | if UseTokenFile then
407 | SaveAccessRefreshTokens
408 | else
409 | LogLine('Please save the access_token');
410 | end;
411 | end;
412 | end;
413 |
414 | if EMail <> '' then
415 | LogLine(Format('%s <%s>', [Fullname, EMail]));
416 | if LastErrorCode <> '' then
417 | LogLine(Format('Error: %s - %s', [LastErrorCode, LastErrorMessage]));
418 | if EMail <> '' then
419 | LogLine('We now have access')
420 | else
421 | LogLine('We don''t have access');
422 |
423 | end;
424 |
425 | // this is used for encoding the access_token for XOAUTH2 in gmail
426 | function TGoogleOAuth2.GetXOAuth2Base64: string;
427 | begin
428 | Result := 'user=%s' + #1 + 'auth=Bearer %s' + #1 + #1;
429 | Result := Format(Result, [EMail, Access_token]);
430 | // Result := SynaCode.EncodeStringBase64(Result);
431 | Result := string(synacode.EncodeBase64(ansistring(Result)));
432 | end;
433 |
434 | {$IFDEF USE_SUPEROBJECT}
435 | procedure TGoogleOAuth2.LoadAccessRefreshTokens;
436 | var
437 | JSON: ISuperObject;
438 | begin
439 | try
440 | JSON := TSuperObject.ParseFile(token_filename, True);
441 | Refresh_token := JSON.S['refresh_token'];
442 | Access_token := JSON.S['access_token'];
443 | finally
444 | JSON := nil;
445 | end;
446 | end;
447 |
448 | procedure TGoogleOAuth2.SaveAccessRefreshTokens;
449 | var
450 | JSON: ISuperObject;
451 | begin
452 | try
453 | JSON := SO;
454 | JSON.S['refresh_token'] := Refresh_token;
455 | JSON.S['access_token'] := Access_token;
456 | JSON.SaveTo(token_filename);
457 | finally
458 | JSON := nil;
459 | end;
460 | end;
461 |
462 | {$ELSE}
463 |
464 | procedure TGoogleOAuth2.LoadAccessRefreshTokens;
465 | var
466 | FS: TFileStream;
467 | P: TJSONParser;
468 | J, D: TJSONData;
469 | begin
470 | if FileExists(token_filename) then
471 | begin
472 | FS := TFileStream.Create(token_filename, fmOpenRead);
473 | P := TJSONParser.Create(FS);
474 | try
475 | J := P.Parse;
476 | D := J.FindPath('refresh_token');
477 | if assigned(D) then refresh_token := D.AsString;
478 | D := J.FindPath('access_token');
479 | if assigned(D) then access_token := D.AsString;
480 | LogLine('Tokens restored from ' + token_filename);
481 | finally
482 | // if assigned(D) then D.Free;
483 | if assigned(J) then J.Free;
484 | P.Free;
485 | FS.Free;
486 | end;
487 | end;
488 | end;
489 |
490 | procedure TGoogleOAuth2.SaveAccessRefreshTokens;
491 | var
492 | J: TJSONData;
493 | begin
494 | J := TJSONObject.Create(['refresh_token', Refresh_token, 'access_token', Access_token]);
495 | try
496 | with TStringList.Create do
497 | try
498 | Add(J.AsJSON);
499 | SaveToFile(token_filename);
500 | LogLine('Tokens saved to ' + token_filename);
501 | finally
502 | Free;
503 | end;
504 | finally
505 | J.Free;
506 | end;
507 | end;
508 | {$ENDIF}
509 |
510 |
511 | type
512 | THTTPServerThread = class(TThread)
513 | private
514 | ListenerSocket: TTCPBlockSocket;
515 | ConnectionSocket: TTCPBlockSocket;
516 | public
517 | Authorize_token: string;
518 | procedure Execute; override;
519 | procedure CancelThread(Sender: TObject; var CanClose: boolean);
520 | end;
521 |
522 | procedure THTTPServerThread.CancelThread(Sender: TObject; var CanClose: boolean);
523 | begin
524 | Terminate;
525 | end;
526 |
527 | procedure THTTPServerThread.Execute;
528 | var
529 | S: string;
530 | method, uri, protocol: string;
531 | OutputDataString: string;
532 | SendDataString: string;
533 | begin
534 | Authorize_token := '';
535 | FreeOnTerminate := False;
536 | ListenerSocket := TTCPBlockSocket.Create;
537 | ConnectionSocket := TTCPBlockSocket.Create;
538 |
539 | try
540 | ListenerSocket.CreateSocket;
541 | ListenerSocket.setLinger(True, 10);
542 | ListenerSocket.Bind('localhost', '1500');
543 | ListenerSocket.Listen;
544 | while not terminated do
545 | begin
546 | Sleep(1000);
547 | // Application.ProcessMessages;
548 | if ListenerSocket.CanRead(1000) and not terminated then
549 | begin
550 | ConnectionSocket.Socket := ListenerSocket.Accept;
551 |
552 | // read request line
553 | S := string(ConnectionSocket.RecvString(1000));
554 | method := fetch(S, ' ');
555 | uri := fetch(S, ' ');
556 | protocol := fetch(S, ' ');
557 |
558 | // read request headers
559 | repeat
560 | S := string(ConnectionSocket.RecvString(1000));
561 | until S = '';
562 |
563 | // /?code=4/fegArZQDUJqFdoCw-1DU16ohYsoA5116feRuCW0LiuQ
564 | // /?error=access_denied
565 | Authorize_token := '';
566 | if Pos('code=', uri) > 0 then
567 | begin
568 | Authorize_token := Copy(uri, Pos('code=', uri) + 5);
569 | end;
570 |
571 | if Authorize_token = '' then
572 | begin
573 | SendDataString :=
574 | '' + CRLF + 'Something went wrong.
Application does not have access.
You can close this page.
' + CRLF;
575 | end
576 | else
577 | begin
578 | SendDataString :=
579 | '' + CRLF + 'Application now has access.
You can close this page.
' + CRLF;
580 | end;
581 |
582 | OutputDataString := 'HTTP/1.0 200' + CRLF;
583 | OutputDataString := OutputDataString + 'Content-type: Text/Html' + CRLF;
584 | OutputDataString := OutputDataString + 'Content-length: ' + IntToStr(Length(SendDataString)) + CRLF;
585 | OutputDataString := OutputDataString + 'Connection: close' + CRLF;
586 | OutputDataString := OutputDataString + 'Date: ' + Rfc822DateTime(now) + CRLF;
587 | OutputDataString := OutputDataString + 'Server: Synapse' + CRLF;
588 | OutputDataString := OutputDataString + '' + CRLF;
589 | ConnectionSocket.SendString(ansistring(OutputDataString));
590 | ConnectionSocket.SendString(ansistring(SendDataString));
591 |
592 | ConnectionSocket.CloseSocket;
593 |
594 | Terminate;
595 | end;
596 | end;
597 |
598 | finally
599 | ConnectionSocket.Free;
600 | ListenerSocket.Free;
601 | end;
602 |
603 | end;
604 |
605 | procedure TGoogleOAuth2.GetAuthorize_token_interactive;
606 | var
607 | URL: string;
608 | Params: string;
609 | GoUrl: variant;
610 | Scope: string;
611 | ServerThread: THTTPServerThread;
612 | dl: TForm;
613 |
614 | function StartBrowser(const FileName: string): boolean;
615 | begin
616 | Result := Shellapi.ShellExecute(0, nil, PChar(FileName), nil, nil, 5 { SW_SHOW }) > 32;
617 | end;
618 |
619 | begin
620 | try
621 |
622 | Scope := FScopes.DelimitedText;
623 | if Scope = '' then
624 | begin
625 | LogLine('No scope specified in GetAccess');
626 | end;
627 |
628 | URL := AuthorizationUrl;
629 | Params := '';
630 | Params := Params + 'response_type=' + EncodeURLElement('code');
631 | Params := Params + '&client_id=' + EncodeURLElement(FClient_id);
632 | Params := Params + '&redirect_uri=' + EncodeURLElement(RedirectUri);
633 | Params := Params + '&scope=' + EncodeURLElement(Scope);
634 |
635 | LogLine('Authorizing...');
636 | GoUrl := URL + '?' + Params;
637 |
638 | ServerThread := THTTPServerThread.Create(False);
639 | try
640 | StartBrowser(GoUrl); // open website
641 |
642 | dl := CreateMessageDialog('Waiting for permission', mtInformation, []);
643 | try
644 |
645 | dl.Height := Round(80 * (dl.PixelsPerInch / 96));
646 | dl.OnCloseQuery := ServerThread.CancelThread;
647 | dl.Top := 38;
648 | dl.Left := 5;
649 | dl.Show;
650 | dl.Repaint;
651 |
652 | while not ServerThread.terminated do
653 | begin
654 | Sleep(1);
655 | Application.ProcessMessages;
656 | end;
657 |
658 | ServerThread.WaitFor; // blocking met dialog
659 |
660 | finally
661 | dl.Free;
662 | end;
663 |
664 | Authorize_token := ServerThread.Authorize_token;
665 | finally
666 | ServerThread.Free;
667 | end;
668 |
669 | except
670 | // on E: EOleSysError do ;
671 | on E: Exception do
672 | begin
673 | DebugLine('Browser closed without confirmation.');
674 | DebugLine('Exception: ' + E.Message);
675 | end;
676 | end;
677 | end;
678 |
679 | procedure TGoogleOAuth2.GetRefresh_token;
680 | var
681 | URL: string;
682 | Params: string;
683 | Response: TMemoryStream;
684 | JSonStr: string;
685 | begin
686 | LastErrorCode := '';
687 | LastErrorMessage := '';
688 |
689 | // If we haven't got a Authentication token we need to ask permission
690 | if Authorize_token = '' then GetAuthorize_token_interactive;
691 | if (Authorize_token = '') then exit;
692 |
693 | LogLine('Getting new Refresh_token');
694 | URL := GetTokenUrl;
695 | Params := '';
696 | Params := Params + 'code=' + EncodeURLElement(Authorize_token);
697 | Params := Params + '&client_id=' + EncodeURLElement(FClient_id);
698 | Params := Params + '&client_secret=' + EncodeURLElement(FClient_secret);
699 | Params := Params + '&redirect_uri=' + EncodeURLElement(RedirectUri);
700 | Params := Params + '&grant_type=' + EncodeURLElement('authorization_code');
701 | Response := TMemoryStream.Create;
702 | try
703 | if HttpPostURL(URL, Params, Response) then
704 | begin
705 | Response.Position := 0;
706 | JSonStr := string(pansichar(Response.Memory));
707 | DebugLine(JSonStr);
708 | LastErrorCode := RetrieveJSONValue(JSonStr, 'error.code');
709 | LastErrorMessage := RetrieveJSONValue(JSonStr, 'error.message');
710 | if LastErrorCode <> '' then
711 | LogLine(Format('Error in GetRefresh_token: %s - %s', [LastErrorCode, LastErrorMessage]));
712 | Refresh_token := RetrieveJSONValue(JSonStr, 'refresh_token');
713 | Access_token := RetrieveJSONValue(JSonStr, 'access_token');
714 | if Access_token <> '' then
715 | LogLine(Format('New refresh- & access_token received (%s, %s)', [Refresh_token, Access_token]));
716 | end;
717 | finally
718 | Response.Free;
719 | end;
720 |
721 | end;
722 |
723 | procedure TGoogleOAuth2.GetAccess_token;
724 | var
725 | URL: string;
726 | Params: string;
727 | Response: TMemoryStream;
728 | JSonStr: string;
729 | begin
730 | LastErrorCode := '';
731 | LastErrorMessage := '';
732 |
733 | // If we haven't got a refresh token we need to get one or possibly re-authenticate
734 | if Refresh_token = '' then GetRefresh_token;
735 | if Refresh_token = '' then exit;
736 | if Access_token <> '' then exit; // we already received via getrefresh_token, so we can exit
737 |
738 | LogLine('Getting new Access_token');
739 | URL := GetTokenUrl;
740 | Params := '';
741 | Params := Params + 'client_id=' + EncodeURLElement(FClient_id);
742 | Params := Params + '&client_secret=' + EncodeURLElement(FClient_secret);
743 | Params := Params + '&refresh_token=' + EncodeURLElement(Refresh_token);
744 | Params := Params + '&grant_type=' + EncodeURLElement('refresh_token');
745 | Response := TMemoryStream.Create;
746 | try
747 | if HttpPostURL(URL, string(Params), Response) then
748 | begin
749 | Response.Position := 0;
750 | JSonStr := string(pansichar(Response.Memory));
751 | DebugLine(JSonStr);
752 | LastErrorCode := RetrieveJSONValue(JSonStr, 'error.code');
753 | LastErrorMessage := RetrieveJSONValue(JSonStr, 'error.message');
754 | if LastErrorCode <> '' then
755 | LogLine(Format('Error in GetRefresh_token: %s - %s', [LastErrorCode, LastErrorMessage]));
756 | Access_token := RetrieveJSONValue(JSonStr, 'access_token');
757 | if Access_token <> '' then
758 | LogLine(Format('New access_token received (%s)', [Access_token]));
759 | end;
760 | finally
761 | Response.Free;
762 | end;
763 | end;
764 |
765 | end.
766 |
--------------------------------------------------------------------------------
/test_full.lpi:
--------------------------------------------------------------------------------
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 |
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 |
52 |
53 |
54 |
55 |
56 |
57 |
58 |
59 |
60 |
61 |
62 |
63 |
64 |
65 |
66 |
67 |
68 |
69 |
70 |
71 |
72 |
73 |
74 |
75 |
76 |
77 |
78 |
79 |
80 |
81 |
82 |
83 |
84 |
85 |
86 |
87 |
88 |
89 |
90 |
91 |
92 |
93 |
94 |
95 |
96 |
97 |
98 |
99 |
100 |
101 |
102 |
103 |
104 |
105 |
106 |
107 |
108 |
109 |
110 |
111 |
--------------------------------------------------------------------------------
/test_full.lpr:
--------------------------------------------------------------------------------
1 | program test_full;
2 |
3 | {$mode objfpc}{$H+}
4 |
5 | uses
6 | {$IFDEF UNIX}{$IFDEF UseCThreads}
7 | cthreads,
8 | {$ENDIF}{$ENDIF}
9 | Interfaces, // this includes the LCL widgetset
10 | Forms, frmMain_Full, google_oauth2, google_calendar, google_drive;
11 |
12 | {$R *.res}
13 |
14 | begin
15 | RequireDerivedFormResource:=True;
16 | Application.Initialize;
17 | Application.CreateForm(TMainform, Mainform);
18 | Application.Run;
19 | end.
20 |
21 |
--------------------------------------------------------------------------------
/test_gmail.lpi:
--------------------------------------------------------------------------------
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 |
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 |
52 |
53 |
54 |
55 |
56 |
57 |
58 |
59 |
60 |
61 |
62 |
63 |
64 |
65 |
66 |
67 |
68 |
69 |
70 |
71 |
72 |
73 |
74 |
75 |
76 |
77 |
78 |
79 |
80 |
81 |
82 |
83 |
84 |
85 |
86 |
87 |
88 |
89 |
90 |
91 |
92 |
93 |
94 |
95 |
96 |
97 |
98 |
99 |
100 |
101 |
102 |
103 |
104 |
105 |
106 |
107 |
108 |
109 |
110 |
111 |
--------------------------------------------------------------------------------
/test_gmail.lpr:
--------------------------------------------------------------------------------
1 | program test_gmail;
2 |
3 | {$mode objfpc}{$H+}
4 |
5 | uses
6 | {$IFDEF UNIX}{$IFDEF UseCThreads}
7 | cthreads,
8 | {$ENDIF}{$ENDIF}
9 | Interfaces, // this includes the LCL widgetset
10 | Forms, frmMain_GMail, google_oauth2, google_calendar, google_drive;
11 |
12 | {$R *.res}
13 |
14 | begin
15 | RequireDerivedFormResource:=True;
16 | Application.Initialize;
17 | Application.CreateForm(TMainform, Mainform);
18 | Application.Run;
19 | end.
20 |
21 |
--------------------------------------------------------------------------------