├── 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 | <ResourceType Value="res"/> 13 | <UseXPManifest Value="True"/> 14 | </General> 15 | <i18n> 16 | <EnableI18N LFM="False"/> 17 | </i18n> 18 | <BuildModes Count="1"> 19 | <Item1 Name="Default" Default="True"/> 20 | </BuildModes> 21 | <PublishOptions> 22 | <Version Value="2"/> 23 | <DestinationDirectory Value="C:\Users\Rik\Dropbox\NLDelphi\google-oauth2\trunk"/> 24 | </PublishOptions> 25 | <RunParams> 26 | <FormatVersion Value="2"/> 27 | <Modes Count="1"> 28 | <Mode0 Name="default"/> 29 | </Modes> 30 | </RunParams> 31 | <RequiredPackages Count="3"> 32 | <Item1> 33 | <PackageName Value="FCL"/> 34 | </Item1> 35 | <Item2> 36 | <PackageName Value="laz_synapse"/> 37 | </Item2> 38 | <Item3> 39 | <PackageName Value="LCL"/> 40 | </Item3> 41 | </RequiredPackages> 42 | <Units Count="6"> 43 | <Unit0> 44 | <Filename Value="test_full.lpr"/> 45 | <IsPartOfProject Value="True"/> 46 | </Unit0> 47 | <Unit1> 48 | <Filename Value="frmmain_full.pas"/> 49 | <IsPartOfProject Value="True"/> 50 | <ComponentName Value="Mainform"/> 51 | <HasResources Value="True"/> 52 | <ResourceBaseClass Value="Form"/> 53 | <UnitName Value="frmMain_Full"/> 54 | </Unit1> 55 | <Unit2> 56 | <Filename Value="google_oauth2.pas"/> 57 | <IsPartOfProject Value="True"/> 58 | </Unit2> 59 | <Unit3> 60 | <Filename Value="README.md"/> 61 | <IsPartOfProject Value="True"/> 62 | </Unit3> 63 | <Unit4> 64 | <Filename Value="google_calendar.pas"/> 65 | <IsPartOfProject Value="True"/> 66 | </Unit4> 67 | <Unit5> 68 | <Filename Value="google_drive.pas"/> 69 | <IsPartOfProject Value="True"/> 70 | </Unit5> 71 | </Units> 72 | </ProjectOptions> 73 | <CompilerOptions> 74 | <Version Value="11"/> 75 | <PathDelim Value="\"/> 76 | <Target> 77 | <Filename Value="test_full"/> 78 | </Target> 79 | <SearchPaths> 80 | <IncludeFiles Value="$(ProjOutDir)"/> 81 | <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> 82 | </SearchPaths> 83 | <Linking> 84 | <Debugging> 85 | <UseHeaptrc Value="True"/> 86 | </Debugging> 87 | <Options> 88 | <Win32> 89 | <GraphicApplication Value="True"/> 90 | </Win32> 91 | </Options> 92 | </Linking> 93 | </CompilerOptions> 94 | <Debugging> 95 | <Exceptions Count="4"> 96 | <Item1> 97 | <Name Value="EAbort"/> 98 | </Item1> 99 | <Item2> 100 | <Name Value="ECodetoolError"/> 101 | </Item2> 102 | <Item3> 103 | <Name Value="EFOpenError"/> 104 | </Item3> 105 | <Item4> 106 | <Name Value="EOleSysError"/> 107 | </Item4> 108 | </Exceptions> 109 | </Debugging> 110 | </CONFIG> 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 | <?xml version="1.0" encoding="UTF-8"?> 2 | <CONFIG> 3 | <ProjectOptions> 4 | <Version Value="12"/> 5 | <PathDelim Value="\"/> 6 | <General> 7 | <Flags> 8 | <CompatibilityMode Value="True"/> 9 | </Flags> 10 | <SessionStorage Value="InProjectDir"/> 11 | <Title Value="test_gmail"/> 12 | <ResourceType Value="res"/> 13 | <UseXPManifest Value="True"/> 14 | </General> 15 | <i18n> 16 | <EnableI18N LFM="False"/> 17 | </i18n> 18 | <BuildModes Count="1"> 19 | <Item1 Name="Default" Default="True"/> 20 | </BuildModes> 21 | <PublishOptions> 22 | <Version Value="2"/> 23 | <DestinationDirectory Value="C:\Users\Rik\Dropbox\NLDelphi\google-oauth2\trunk"/> 24 | </PublishOptions> 25 | <RunParams> 26 | <FormatVersion Value="2"/> 27 | <Modes Count="1"> 28 | <Mode0 Name="default"/> 29 | </Modes> 30 | </RunParams> 31 | <RequiredPackages Count="3"> 32 | <Item1> 33 | <PackageName Value="FCL"/> 34 | </Item1> 35 | <Item2> 36 | <PackageName Value="laz_synapse"/> 37 | </Item2> 38 | <Item3> 39 | <PackageName Value="LCL"/> 40 | </Item3> 41 | </RequiredPackages> 42 | <Units Count="6"> 43 | <Unit0> 44 | <Filename Value="test_gmail.lpr"/> 45 | <IsPartOfProject Value="True"/> 46 | </Unit0> 47 | <Unit1> 48 | <Filename Value="frmmain_gmail.pas"/> 49 | <IsPartOfProject Value="True"/> 50 | <ComponentName Value="Mainform"/> 51 | <HasResources Value="True"/> 52 | <ResourceBaseClass Value="Form"/> 53 | <UnitName Value="frmMain_GMail"/> 54 | </Unit1> 55 | <Unit2> 56 | <Filename Value="google_oauth2.pas"/> 57 | <IsPartOfProject Value="True"/> 58 | </Unit2> 59 | <Unit3> 60 | <Filename Value="README.md"/> 61 | <IsPartOfProject Value="True"/> 62 | </Unit3> 63 | <Unit4> 64 | <Filename Value="google_calendar.pas"/> 65 | <IsPartOfProject Value="True"/> 66 | </Unit4> 67 | <Unit5> 68 | <Filename Value="google_drive.pas"/> 69 | <IsPartOfProject Value="True"/> 70 | </Unit5> 71 | </Units> 72 | </ProjectOptions> 73 | <CompilerOptions> 74 | <Version Value="11"/> 75 | <PathDelim Value="\"/> 76 | <Target> 77 | <Filename Value="test_gmail"/> 78 | </Target> 79 | <SearchPaths> 80 | <IncludeFiles Value="$(ProjOutDir)"/> 81 | <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> 82 | </SearchPaths> 83 | <Linking> 84 | <Debugging> 85 | <UseHeaptrc Value="True"/> 86 | </Debugging> 87 | <Options> 88 | <Win32> 89 | <GraphicApplication Value="True"/> 90 | </Win32> 91 | </Options> 92 | </Linking> 93 | </CompilerOptions> 94 | <Debugging> 95 | <Exceptions Count="4"> 96 | <Item1> 97 | <Name Value="EAbort"/> 98 | </Item1> 99 | <Item2> 100 | <Name Value="ECodetoolError"/> 101 | </Item2> 102 | <Item3> 103 | <Name Value="EFOpenError"/> 104 | </Item3> 105 | <Item4> 106 | <Name Value="EOleSysError"/> 107 | </Item4> 108 | </Exceptions> 109 | </Debugging> 110 | </CONFIG> 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 | --------------------------------------------------------------------------------