· 8 years ago · Dec 24, 2016, 05:56 PM
1unit frmMain;
2
3{$mode objfpc}{$H+}
4
5interface
6
7uses
8 Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
9 ComCtrls, ExtCtrls, Grids, blcksock,jsonConf;
10
11type
12
13 { TMainform }
14
15 TMainform = class(TForm)
16 btGetAccess: TButton;
17 btGetFileList: TButton;
18 btSendMail: TButton;
19 btRemoveTokens: TButton;
20 btClearLog: TButton;
21 btnSimpleUpload: TButton;
22 btnUploadWithResume: TButton;
23 Button5: TButton;
24 btGetAppointments: TButton;
25 btClearDebug: TButton;
26 Button8: TButton;
27 btGetContacts: TButton;
28 CheckGroup1: TCheckGroup;
29
30 ckForceManualAuth: TCheckBox;
31 ckUseBrowserTitle: TCheckBox;
32
33
34 edBody: TMemo;
35 Edit1: TEdit;
36 Edit2: TEdit;
37 Edit3: TEdit;
38 edRecipient: TEdit;
39 edSender: TEdit;
40 edSubject: TEdit;
41 Label1: TLabel;
42 Label2: TLabel;
43 Label3: TLabel;
44 Label4: TLabel;
45 Label5: TLabel;
46 Label6: TLabel;
47 Memo1: TMemo;
48 Memo2: TMemo;
49 OpenDialog1: TOpenDialog;
50 PageControl1: TPageControl;
51 PageControl2: TPageControl;
52 PageControl3: TPageControl;
53 PageControl4: TPageControl;
54 PageControl5: TPageControl;
55 Panel1: TPanel;
56 ProgressBar1: TProgressBar;
57 StringGrid1: TStringGrid;
58 StringGrid2: TStringGrid;
59 StringGrid3: TStringGrid;
60 TabSheet1: TTabSheet;
61 TabSheet10: TTabSheet;
62 TabSheet11: TTabSheet;
63 TabSheet12: TTabSheet;
64 TabSheet13: TTabSheet;
65 TabSheet2: TTabSheet;
66 TabSheet3: TTabSheet;
67 TabSheet4: TTabSheet;
68 TabSheet5: TTabSheet;
69 TabSheet6: TTabSheet;
70 TabSheet7: TTabSheet;
71 TabSheet8: TTabSheet;
72 TabSheet9: TTabSheet;
73 procedure btGetAccessClick(Sender: TObject);
74 procedure btGetFileListClick(Sender: TObject);
75 procedure btSendMailClick(Sender: TObject);
76 procedure btRemoveTokensClick(Sender: TObject);
77 procedure btClearLogClick(Sender: TObject);
78 procedure btGetAppointmentsClick(Sender: TObject);
79 procedure btClearDebugClick(Sender: TObject);
80 procedure btnSimpleUploadClick(Sender: TObject);
81 procedure btnUploadWithResumeClick(Sender: TObject);
82 procedure Button1Click(Sender: TObject);
83 procedure FormCreate(Sender: TObject);
84 procedure StringGrid1DblClick(Sender: TObject);
85 private
86 { private declarations }
87 public
88 { public declarations }
89 procedure AddToLog(Str: string);
90 procedure CheckTokenFile;
91 procedure Status(Sender: TObject; Reason: THookSocketReason; const Value: String);
92 function GetJSONParam(filename,param:string):string;
93 procedure SetJSONParam(filename,param,value:string);
94
95 end;
96
97var
98 Mainform: TMainform;
99
100implementation
101
102uses
103 google_oauth2,
104 google_calendar,
105 google_drive,
106
107 smtpsend,
108 httpsend,
109 synautil,
110 Windows,
111 comobj;
112
113{$R *.lfm}
114
115{ TMainform }
116
117const
118 client_id = '896304839415-nnl5e0smrtakhr9r2l3bno0tes2mrtgk.apps.googleusercontent.com';
119 client_secret = 'dUahHDn3IMyhCIk3qD4tf8E_';
120
121procedure TMainform.AddToLog(Str: string);
122begin
123 Memo1.Lines.Add(Str);
124end;
125
126procedure TMainform.CheckTokenFile;
127begin
128
129 if FileExists('tokens.dat') then // already tokens
130 begin
131 CheckGroup1.Enabled := False;
132 CheckGroup1.Caption := 'Access (scope) remove tokens.dat first to get new access';
133 btGetAccess.Caption := 'Check access';
134 ckForceManualAuth.Enabled := False;
135 ckUseBrowserTitle.Enabled := False;
136 end
137 else
138 begin
139 CheckGroup1.Enabled := True;
140 CheckGroup1.Caption := 'Access (scope)';
141 btGetAccess.Caption := 'Get access';
142 ckForceManualAuth.Enabled := True;
143 ckUseBrowserTitle.Enabled := True;
144 end;
145
146end;
147
148procedure TMainform.FormCreate(Sender: TObject);
149begin
150 Memo1.Clear;
151 Memo2.Clear;
152
153 //Left := (Screen.Width - round(Screen.Width * 0.8)) div 2;
154 //Top := (Screen.Height - round(Screen.Height * 0.8)) div 2;
155 Width := round(Screen.Width * 0.6);
156 Height := round(Screen.Height * 0.9) - 100;
157 Top := 100;
158
159 ckForceManualAuth.Checked := False;
160 ckUseBrowserTitle.Checked := True;
161
162 if CheckGroup1.Items.Count > 2 then
163 begin
164 CheckGroup1.Checked[0] := True;
165 CheckGroup1.Checked[1] := True;
166 CheckGroup1.Checked[2] := True;
167 CheckGroup1.CheckEnabled[0] := False;
168 CheckGroup1.CheckEnabled[1] := False;
169 end;
170
171 PageControl1.ActivePageIndex := 0;
172
173 CheckTokenFile;
174
175end;
176
177procedure TMainform.StringGrid1DblClick(Sender: TObject);
178var
179 Browser: olevariant;
180 GoUrl: variant;
181begin
182
183 GoUrl := '';
184 with TStringGrid(Sender) do
185 GoUrl := Cells[4, Row];
186 if Pos('https://', GoUrl) = 0 then
187 exit;
188
189 Browser := CreateOleObject('InternetExplorer.Application');
190 Browser.Visible := True;
191 Browser.AddressBar := False;
192 Browser.Menubar := False;
193 Browser.ToolBar := False;
194 Browser.StatusBar := False;
195 Browser.Left := (Screen.Width - round(Screen.Width * 0.8)) div 2;
196 Browser.Top := (Screen.Height - round(Screen.Height * 0.8)) div 2;
197 Browser.Width := round(Screen.Width * 0.8);
198 Browser.Height := round(Screen.Height * 0.8);
199 Browser.Navigate(GoUrl);
200
201end;
202
203procedure TMainform.btGetAccessClick(Sender: TObject);
204var
205 gOAuth2: TGoogleOAuth2;
206 Scopes: GoogleScopeSet;
207begin
208 // Onetime authentication
209 // Save tokens to token.dat
210 gOAuth2 := TGoogleOAuth2.Create(client_id, client_secret);
211 try
212
213 Scopes := [];
214 if CheckGroup1.Checked[2] then Include(Scopes, goMail);
215 if CheckGroup1.Checked[3] then Include(Scopes, goContacts);
216 if CheckGroup1.Checked[4] then Include(Scopes, goCalendar);
217 if CheckGroup1.Checked[5] then Include(Scopes, goDrive);
218
219 gOAuth2.LogMemo := Memo1;
220 gOAuth2.DebugMemo := Memo2;
221 gOAuth2.ForceManualAuth := ckForceManualAuth.Checked;
222 gOAuth2.UseBrowserTitle := ckUseBrowserTitle.Checked;
223 gOAuth2.GetAccess(Scopes, True); // <- get from file
224
225 if gOAuth2.EMail <> '' then
226 edSender.Text := format('%s <%s>', [gOAuth2.FullName, gOAuth2.EMail]);
227
228 CheckTokenFile;
229
230 finally
231 gOAuth2.Free;
232 end;
233
234end;
235
236
237procedure TMainform.btRemoveTokensClick(Sender: TObject);
238begin
239 if not FileExists('tokens.dat') then
240 begin
241 AddToLog('tokens.dat didn''t exist');
242 exit;
243 end;
244
245 Deletefile('tokens.dat');
246
247 if not FileExists('tokens.dat') then
248 AddToLog('tokens.dat deleted')
249 else
250 AddToLog('error while removing tokens.dat');
251
252 CheckTokenFile;
253
254end;
255
256// -----------------------------------------------------
257// Little hack for TSMTPSend to give the command XOAUTH2
258// -----------------------------------------------------
259
260type
261 TmySMTPSend = class helper for TSMTPSend
262 public
263 function DoXOAuth2(const Value: string): boolean;
264 function ChallengeError(): string;
265 end;
266
267
268function TmySMTPSend.DoXOAuth2(const Value: string): boolean;
269var
270 x: integer;
271 s: string;
272begin
273 Sock.SendString('AUTH XOAUTH2 ' + Value + CRLF);
274 repeat
275 s := Sock.RecvString(FTimeout);
276 if Sock.LastError <> 0 then
277 Break;
278 until Pos('-', s) <> 4;
279 x := StrToIntDef(Copy(s, 1, 3), 0);
280 Result := (x = 235);
281end;
282
283function TmySMTPSend.ChallengeError(): string;
284var
285 s: string;
286begin
287 Result := '';
288 Sock.SendString('' + CRLF);
289 repeat
290 s := Sock.RecvString(FTimeout);
291 if Sock.LastError <> 0 then
292 Break;
293 if Result <> '' then
294 Result := Result + CRLF;
295 Result := Result + s;
296 until Pos('-', s) <> 4;
297end;
298
299// -----------------------------------------------------
300// -----------------------------------------------------
301
302procedure TMainform.btSendMailClick(Sender: TObject);
303var
304 gOAuth2: TGoogleOAuth2;
305 smtp: TSMTPSend;
306 msg_lines: TStringList;
307begin
308 if (edRecipient.Text = '') or (edRecipient.Text = 'recipient@valid_domain.com') then
309 begin
310 Memo1.Lines.Add('Please change the recipient');
311 exit;
312 end;
313
314 if not FileExists('tokens.dat') then
315 begin
316 // first get all access clicked on Groupbox
317 btGetAccess.Click;
318 end;
319
320 gOAuth2 := TGoogleOAuth2.Create(client_id, client_secret);
321 smtp := TSMTPSend.Create;
322 msg_lines := TStringList.Create;
323 try
324 btSendMail.Enabled := False;
325
326 // first get oauthToken
327 gOAuth2.LogMemo := Memo1;
328 gOAuth2.DebugMemo := Memo2;
329 gOAuth2.ForceManualAuth := ckForceManualAuth.Checked;
330 gOAuth2.UseBrowserTitle := ckUseBrowserTitle.Checked;
331 gOAuth2.GetAccess([], True); // <- get from file
332 // no need for scope because we should already have access
333 // via the btGetAccess for all the scopes in Groupbox
334 if gOAuth2.EMail = '' then
335 exit;
336
337 CheckTokenFile;
338
339 edSender.Text := format('%s <%s>', [gOAuth2.FullName, gOAuth2.EMail]);
340
341 msg_lines.Add('From: ' + edSender.Text);
342 msg_lines.Add('To: ' + edRecipient.Text);
343 msg_lines.Add('Subject: ' + edSubject.Text);
344 msg_lines.Add('');
345 msg_lines.Add(edBody.Text);
346
347 smtp.TargetHost := 'smtp.gmail.com';
348 smtp.TargetPort := '587';
349
350 AddToLog('SMTP Login');
351 if not smtp.Login() then
352 begin
353 AddToLog('SMTP ERROR: Login:' + smtp.EnhCodeString);
354 exit;
355 end;
356 if not smtp.StartTLS() then
357 begin
358 AddToLog('SMTP ERROR: StartTLS:' + smtp.EnhCodeString);
359 exit;
360 end;
361
362 AddToLog('XOAUTH2');
363 if not smtp.DoXOAuth2(gOAuth2.GetXOAuth2Base64) then
364 begin
365 AddToLog('XOAUTH2 ERROR: ' + CRLF + smtp.ChallengeError());
366 exit;
367 end;
368
369 AddToLog('SMTP Mail');
370 if not smtp.MailFrom(gOAuth2.EMail, Length(gOAuth2.EMail)) then
371 begin
372 AddToLog('SMTP ERROR: MailFrom:' + smtp.EnhCodeString);
373 exit;
374 end;
375 if not smtp.MailTo(edRecipient.Text) then
376 begin
377 AddToLog('SMTP ERROR: MailTo:' + smtp.EnhCodeString);
378 exit;
379 end;
380 if not smtp.MailData(msg_lines) then
381 begin
382 AddToLog('SMTP ERROR: MailData:' + smtp.EnhCodeString);
383 exit;
384 end;
385
386 AddToLog('SMTP Logout');
387 if not smtp.Logout() then
388 begin
389 AddToLog('SMTP ERROR: Logout:' + smtp.EnhCodeString);
390 exit;
391 end;
392
393 AddToLog('OK !');
394
395 finally
396 gOAuth2.Free;
397 smtp.Free;
398 msg_lines.Free;
399 btSendMail.Enabled := True;
400 end;
401
402end;
403
404procedure TMainform.btClearLogClick(Sender: TObject);
405begin
406 Memo1.Clear;
407end;
408
409// Bubblesort Integer
410
411const
412 // Define the Separator
413 TheSeparator = #254;
414
415procedure BubbleSort_int(Items: TStrings);
416var
417 done: boolean;
418 ThePosition, ThePosition2, i, n: integer;
419 TempString, TempString2, MyString, Mystring2, Dummy: string;
420begin
421 n := Items.Count;
422 repeat
423 done := True;
424 for i := 0 to n - 2 do
425 begin
426 MyString := items[i];
427 MyString2 := items[i + 1];
428 ThePosition := Pos(TheSeparator, MyString);
429 ThePosition2 := Pos(TheSeparator, MyString2);
430 TempString := Copy(MyString, 1, ThePosition);
431 TempString2 := Copy(MyString2, 1, ThePosition2);
432 if AnsiCompareText(TempString, TempString2) < 0 then
433 begin
434 Dummy := Items[i];
435 Items[i] := Items[i + 1];
436 Items[i + 1] := Dummy;
437 done := False;
438 end;
439 end;
440 until done;
441end;
442
443procedure SortStringGrid(var GenStrGrid: TStringGrid; ThatCol: integer);
444var
445 CountItem, I, J, K, ThePosition: integer;
446 MyList: TStringList;
447 MyString, TempString: string;
448begin
449 // Give the number of rows in the StringGrid
450 CountItem := GenStrGrid.RowCount;
451 //Create the List
452 MyList := TStringList.Create;
453 MyList.Sorted := False;
454 try
455 begin
456 for I := 1 to (CountItem - 1) do
457 MyList.Add(GenStrGrid.Rows[I].Strings[ThatCol] + TheSeparator +
458 GenStrGrid.Rows[I].Text);
459 //Sort the List
460 //Mylist.Sort; INSTEAD
461 BubbleSort_int(Mylist);
462
463 for K := 1 to Mylist.Count do
464 begin
465 //Take the String of the line (K – 1)
466 MyString := MyList.Strings[(K - 1)];
467 //Find the position of the Separator in the String
468 ThePosition := Pos(TheSeparator, MyString);
469 TempString := '';
470 {Eliminate the Text of the column on which we have sorted the StringGrid}
471 TempString := Copy(MyString, (ThePosition + 1), Length(MyString));
472 MyList.Strings[(K - 1)] := '';
473 MyList.Strings[(K - 1)] := TempString;
474 end;
475
476 // Refill the StringGrid
477 for J := 1 to (CountItem - 1) do
478 GenStrGrid.Rows[J].Text := MyList.Strings[(J - 1)];
479 end;
480 finally
481 //Free the List
482 MyList.Free;
483 end;
484end;
485
486
487procedure TMainform.btGetAppointmentsClick(Sender: TObject);
488var
489 Response: TStringList;
490 Q: integer;
491 StartDt: string;
492 EndDt: string;
493 nwWidth: integer;
494
495var
496 ds: TGoogleCalendar;
497
498begin
499
500 Response := TStringList.Create;
501 ds := TGoogleCalendar.Create(Self, client_id, client_secret);
502 try
503 btGetAppointments.Enabled := False;
504
505 ds.gOAuth2.LogMemo := Memo1;
506 ds.gOAuth2.DebugMemo := Memo2;
507 ds.gOAuth2.ForceManualAuth := ckForceManualAuth.Checked;
508 ds.gOAuth2.UseBrowserTitle := ckUseBrowserTitle.Checked;
509 ds.gOAuth2.GetAccess([goCalendar], True);
510
511 CheckTokenFile;
512
513 if ds.gOAuth2.EMail = '' then
514 exit;
515
516 ds.Open;
517 ds.Populate();
518
519 StringGrid1.Options := StringGrid1.Options + [goRowSelect];
520 StringGrid1.ColCount := 5;
521 StringGrid1.RowCount := 2;
522 StringGrid1.Cells[1, 0] := 'Start';
523 StringGrid1.Cells[2, 0] := 'Eind';
524 StringGrid1.Cells[3, 0] := 'Afspraak';
525 StringGrid1.Cells[4, 0] := 'Link';
526
527 AddToLog('Busy filling grid');
528 SendMessage(StringGrid1.Handle, WM_SETREDRAW, 0, 0);
529 try
530 ds.First;
531 while not ds.EOF do
532 begin
533
534 with StringGrid1 do
535 begin
536 Cells[1, StringGrid1.RowCount - 1] := ds.FieldByName('start').AsString;
537 Cells[2, StringGrid1.RowCount - 1] := ds.FieldByName('end').AsString;
538 Cells[3, StringGrid1.RowCount - 1] := ds.FieldByName('summary').AsString;
539 Cells[4, StringGrid1.RowCount - 1] := ds.FieldByName('htmllink').AsString;
540 end;
541
542 for Q := 1 to 4 do
543 begin
544 nwWidth := StringGrid1.Canvas.TextWidth(
545 StringGrid1.Cells[Q, StringGrid1.RowCount - 1]);
546 if nwWidth > StringGrid1.ColWidths[Q] then
547 StringGrid1.ColWidths[Q] := nwWidth + 20;
548 end;
549 Application.ProcessMessages;
550 StringGrid1.RowCount := StringGrid1.RowCount + 1;
551
552 ds.Next;
553 end;
554
555 AddToLog('Sorting');
556 SortStringGrid(StringGrid1, 1);
557
558 StringGrid1.ColWidths[0] := 10;
559 StringGrid1.ColWidths[4] := 0; // <- also not -1
560 // StringGrid1.Columns[4].Visible := false; // <- why does this give an error ?
561 while (StringGrid1.RowCount > 2) and (StringGrid1.Cells[3, 1] = '') do
562 StringGrid1.DeleteRow(1);
563
564 AddToLog('Done filling grid');
565
566 finally
567 SendMessage(StringGrid1.Handle, WM_SETREDRAW, 1, 0);
568 StringGrid1.Repaint;
569 StringGrid1.SetFocus;
570 end;
571
572 finally
573 Response.Free;
574 ds.Free;
575 btGetAppointments.Enabled := True;
576 end;
577
578end;
579
580procedure TMainform.btGetFileListClick(Sender: TObject);
581var
582 Response: TStringList;
583 Q: integer;
584 StartDt: string;
585 EndDt: string;
586 nwWidth: integer;
587
588var
589 ds: TGoogleDrive;
590
591begin
592
593 Response := TStringList.Create;
594 ds := TGoogleDrive.Create(Self, client_id, client_secret);
595 try
596 btGetFileList.Enabled := False;
597
598 ds.gOAuth2.LogMemo := Memo1;
599 ds.gOAuth2.DebugMemo := Memo2;
600 ds.gOAuth2.ForceManualAuth := ckForceManualAuth.Checked;
601 ds.gOAuth2.UseBrowserTitle := ckUseBrowserTitle.Checked;
602 ds.gOAuth2.GetAccess([goDrive], True);
603
604 CheckTokenFile;
605
606 if ds.gOAuth2.EMail = '' then
607 exit;
608
609 ds.Open;
610 ds.Populate();
611
612 StringGrid3.Options := StringGrid3.Options + [goRowSelect];
613 StringGrid3.ColCount := 6;
614 StringGrid3.RowCount := 2;
615
616 //FieldDefs.Add('title', ftString, 25, False);
617 //FieldDefs.Add('description', ftString, 255, False);
618 //FieldDefs.Add('created', ftDateTime, 0, False);
619 //FieldDefs.Add('modified', ftDateTime, 0, False);
620 //FieldDefs.Add('downloadurl', ftString, 255, False);
621 //FieldDefs.Add('filename', ftString, 255, False);
622 //FieldDefs.Add('md5', ftString, 255, False);
623 //FieldDefs.Add('filesize', ftInteger, 0, False);
624
625 StringGrid3.Cells[1, 0] := 'Title';
626 StringGrid3.Cells[2, 0] := 'Created';
627 StringGrid3.Cells[3, 0] := 'Modified';
628 StringGrid3.Cells[4, 0] := 'Filename';
629 StringGrid3.Cells[5, 0] := 'Size';
630
631 AddToLog('Busy filling grid');
632 SendMessage(StringGrid3.Handle, WM_SETREDRAW, 0, 0);
633 try
634 ds.First;
635 while not ds.EOF do
636 begin
637
638 with StringGrid3 do
639 begin
640 Cells[1, StringGrid3.RowCount - 1] := ds.FieldByName('title').AsString;
641 Cells[2, StringGrid3.RowCount - 1] := ds.FieldByName('created').AsString;
642 Cells[3, StringGrid3.RowCount - 1] := ds.FieldByName('modified').AsString;
643 Cells[4, StringGrid3.RowCount - 1] := ds.FieldByName('filename').AsString;
644 Cells[5, StringGrid3.RowCount - 1] := ds.FieldByName('filesize').AsString;
645 end;
646
647 for Q := 0 to 5 do
648 begin
649 nwWidth := StringGrid3.Canvas.TextWidth(StringGrid3.Cells[Q, StringGrid3.RowCount - 1]);
650 if nwWidth > StringGrid3.ColWidths[Q] then
651 StringGrid3.ColWidths[Q] := nwWidth + 20;
652 end;
653 Application.ProcessMessages;
654 StringGrid3.RowCount := StringGrid3.RowCount + 1;
655
656 ds.Next;
657 end;
658
659 StringGrid3.ColWidths[0] := 10;
660 while (StringGrid3.RowCount > 2) and (StringGrid3.Cells[3, 1] = '') do
661 StringGrid3.DeleteRow(1);
662
663 AddToLog('Done filling grid');
664
665 finally
666 SendMessage(StringGrid3.Handle, WM_SETREDRAW, 1, 0);
667 StringGrid3.Repaint;
668 StringGrid3.SetFocus;
669 end;
670
671 finally
672 Response.Free;
673 ds.Free;
674 btGetFileList.Enabled := true;
675 end;
676 //
677end;
678
679procedure TMainform.btClearDebugClick(Sender: TObject);
680begin
681 Memo2.Clear;
682end;
683
684
685
686
687
688
689
690
691function Gdrivepostfile(const URL, auth, FileName: string; const Data: TStream;
692 const ResultData: TStrings): boolean;
693var
694 HTTP: THTTPSend;
695 Bound, s: string;
696begin
697 Bound := IntToHex(Random(MaxInt), 8) + '_Synapse_boundary';
698 HTTP := THTTPSend.Create;
699 try
700 s := '--' + Bound + CRLF;
701 s := s + 'Content-Type: application/json; charset=UTF-8' + CRLF + CRLF;
702 s := s + '{' + CRLF;
703 s := s + '"name": "' + ExtractFileName(FileName) + '"' + CRLF;
704 s := s + '}' + CRLF + CRLF;
705
706 s := s + '--' + Bound + CRLF;
707 s := s + 'Content-Type: application/octet-stream' + CRLF + CRLF;
708 WriteStrToStream(HTTP.Document, ansistring(s));
709 HTTP.Document.CopyFrom(Data, 0);
710
711 s := CRLF + '--' + Bound + '--' + CRLF;
712 WriteStrToStream(HTTP.Document, ansistring(s));
713
714 HTTP.Headers.Add('Authorization: Bearer ' + auth);
715 HTTP.MimeType := 'multipart/form-data; boundary=' + Bound;
716 Result := HTTP.HTTPMethod('POST', URL);
717 Mainform.Memo2.Lines.Add(HTTP.Headers.Text);
718
719 if Result then
720 ResultData.LoadFromStream(HTTP.Document);
721 finally
722 HTTP.Free;
723 end;
724end;
725
726procedure TMainform.btnSimpleUploadClick(Sender: TObject);
727var
728 URL: string;
729 gOAuth2: TGoogleOAuth2;
730 Data: TFileStream;
731 ResultData: TStringList;
732begin
733 // URL := 'https://www.googleapis.com/upload/drive/v3/files?uploadType=media';
734 // URL := 'https://www.googleapis.com/upload/drive/v3/files?uploadType=resumable';
735 URL := 'https://www.googleapis.com/upload/drive/v3/files?uploadType=multipart';
736
737 gOAuth2 := TGoogleOAuth2.Create(client_id, client_secret);
738 ResultData := TStringList.Create;
739 Data := TFileStream.Create('c:\temp\test.txt', fmOpenRead);
740 try
741 if not FileExists('tokens.dat') then
742 begin
743 // first get all access clicked on Groupbox
744 btGetAccess.Click;
745 end;
746
747 gOAuth2.LogMemo := Memo1;
748 gOAuth2.DebugMemo := Memo2;
749 gOAuth2.ForceManualAuth := ckForceManualAuth.Checked;
750 gOAuth2.UseBrowserTitle := ckUseBrowserTitle.Checked;
751 gOAuth2.GetAccess([], True); // <- get from file
752 // no need for scope because we should already have access
753 // via the btGetAccess for all the scopes in Groupbox
754 if gOAuth2.EMail = '' then
755 exit;
756
757 Gdrivepostfile(URL, gOAuth2.Access_token, 'test.txt', Data, ResultData);
758
759 Memo1.Lines.Add(ResultData.Text);
760
761 finally
762 Data.Free;
763 ResultData.Free;
764 gOAuth2.Free;
765 end;
766
767end;
768
769function Retrieve_Gdrive_resumable_URI(const URL, auth, FileName,Description: string; const Data: TStream): string;
770var
771 HTTP: THTTPSend;
772 s: string;
773 i: integer;
774begin
775 Result := '';
776 HTTP := THTTPSend.Create;
777 try
778 s := Format('{' + CRLF + '"name": "%s",' + CRLF +'"description": "%s"' + CRLF + '}', [ExtractFileName(FileName),Description]);
779 WriteStrToStream(HTTP.Document, ansistring(s));
780 HTTP.Headers.Add('Authorization: Bearer ' + auth);
781 HTTP.Headers.Add(Format('X-Upload-Content-Length: %d', [Data.Size]));
782 HTTP.MimeType := 'application/json; charset=UTF-8';
783 if not HTTP.HTTPMethod('POST', URL) then exit;
784 Result := HTTP.ResultString; // for any errors
785 for i := 0 to HTTP.Headers.Count - 1 do
786 begin
787 if Pos('Location: ', HTTP.Headers.Strings[i]) > 0 then
788 begin
789 Result := StringReplace(HTTP.Headers.Strings[i], 'Location: ', '', []);
790 break;
791 end;
792 end;
793 finally
794 HTTP.Free;
795 end;
796end;
797
798
799procedure TMainform.Status(Sender: TObject; Reason: THookSocketReason; const Value: String);
800begin
801 if Reason = HR_WriteCount then
802 begin
803 ProgressBar1.StepBy(StrToIntDef(Value, 0));
804 Application.ProcessMessages;
805 end;
806end;
807
808function Gdrivepost_resumable_file(const URL: string; const Data: TStream; Progress: TProgressBar): string;
809const
810 MaxChunk = 40 * 256 * 1024; // ALWAYS chunks of 256KB
811var
812 HTTP: THTTPSend;
813 s: string;
814 i: integer;
815 From, Size: integer;
816 Tries, PrevFrom: integer;
817begin
818 Result := '';
819 HTTP := THTTPSend.Create;
820 try
821 // Always check if there already was aborted upload (is easiest)
822 HTTP.Headers.Add('Content-Length: 0');
823 HTTP.Headers.Add('Content-Range: bytes */*');
824
825 if not HTTP.HTTPMethod('PUT', URL) then exit;
826 Result := 'pre - ' + #13 + HTTP.Headers.Text + #13 + #13 + HTTP.ResultString; // for any errors
827 // Mainform.Memo2.Lines.Add('@@@'+Result);
828 From := 0;
829 if HTTP.ResultCode in [200, 201] then
830 begin
831 Result := '200 already uploaded completely';
832 exit;
833 end;
834 if HTTP.ResultCode = 308 then // Resume Incomplete
835 begin
836 for i := 0 to HTTP.Headers.Count - 1 do
837 begin
838 if Pos('Range: bytes=0-', HTTP.Headers.Strings[i]) > 0 then
839 begin
840 s := StringReplace(HTTP.Headers.Strings[i], 'Range: bytes=0-', '', []);
841 From := StrToIntDef(s, -1) + 1; // from 0 or max_range + 1
842 break;
843 end;
844 end;
845 end;
846 if not HTTP.ResultCode in [200, 201, 308] then exit;
847 Tries := 0;
848 PrevFrom := From;
849 Progress.Min := 0;
850 Progress.Max := Data.Size - 1;
851 HTTP.Sock.OnStatus := @Mainform.Status;
852 repeat
853
854 Progress.Position := From;
855
856 HTTP.Document.Clear;
857 HTTP.Headers.Clear;
858
859 // We need to resune upload from position "from"
860 Data.Position := From;
861 Size := Data.Size - From;
862 if Size > MaxChunk then Size := MaxChunk;
863 HTTP.Document.CopyFrom(Data, Size);
864 HTTP.Headers.Add(Format('Content-Range: bytes %d-%d/%d', [From, From + Size - 1, Data.Size]));
865 HTTP.MimeType := '';
866 Mainform.Memo2.Lines.Add(HTTP.Headers.Text);
867 if not HTTP.HTTPMethod('PUT', URL) then exit;
868
869 Result := HTTP.Headers.Text + #13 + #13 + HTTP.ResultString;
870 // Mainform.Memo2.Lines.Add(Result);
871
872 if HTTP.ResultCode in [200, 201] then Result := '200 Upload complete';
873 if HTTP.ResultCode = 308 then // Resume Incomplete
874 begin
875 for i := 0 to HTTP.Headers.Count - 1 do
876 begin
877 if Pos('Range: bytes=0-', HTTP.Headers.Strings[i]) > 0 then
878 begin
879 s := StringReplace(HTTP.Headers.Strings[i], 'Range: bytes=0-', '', []);
880 PrevFrom := From;
881 From := StrToIntDef(s, -1) + 1; // from 0 or max_range + 1
882 break;
883 end;
884 end;
885 end;
886
887 // no 308 with actual transfer is received, increase tries
888 if PrevFrom = From then Inc(Tries);
889
890 until (HTTP.ResultCode in [200, 201]) or (Tries > 1);
891
892 finally
893 HTTP.Free;
894 end;
895
896end;
897
898
899
900procedure TMainform.btnUploadWithResumeClick(Sender: TObject);
901var
902 URL, Res: string;
903 gOAuth2: TGoogleOAuth2;
904 Data: TFileStream;
905 uploadname,uploadparam:string;
906begin
907 // https://developers.google.com/drive/v3/web/manage-uploads
908
909if opendialog1.Execute then
910 begin
911 uploadname:=opendialog1.filename;
912 end;
913
914if uploadname='' then exit;
915
916 URL := 'https://www.googleapis.com/upload/drive/v3/files?uploadType=resumable';
917 gOAuth2 := TGoogleOAuth2.Create(client_id, client_secret);
918 Data := TFileStream.Create('backup.fdb', fmOpenRead);
919 try
920 if not FileExists('tokens.dat') then
921 begin
922 // first get all access clicked on Groupbox
923 btGetAccess.Click;
924 end;
925
926 gOAuth2.LogMemo := Memo1;
927 gOAuth2.DebugMemo := Memo2;
928 gOAuth2.ForceManualAuth := ckForceManualAuth.Checked;
929 gOAuth2.UseBrowserTitle := ckUseBrowserTitle.Checked;
930 gOAuth2.GetAccess([], True); // <- get from file
931 // no need for scope because we should already have access
932 // via the btGetAccess for all the scopes in Groupbox
933 if gOAuth2.EMail = '' then exit;
934
935
936
937 // if pending transfer take that one
938 // and ask user
939 // "Previous upload was aborted. Do you want to resume?"
940
941
942 URL := Retrieve_Gdrive_resumable_URI(URL, gOAuth2.Access_token, extractfilename(uploadname),Edit3.text, Data);
943 if URL <> '' then
944 begin
945
946 Memo1.Lines.Add('Result request upload_id = ' + URL);
947 if pos('upload_id', URL) > 0 then
948 begin
949
950 uploadparam:=extractfilepath(paramstr(0))+extractfilename(uploadname)+'.rvk';
951
952 if not fileexists(uploadparam) then begin
953 SetJsonparam(uploadparam,'URL',URL);
954 SetJsonparam(uploadparam,'Filename',extractfilename(uploadname));
955 SetJsonparam(uploadparam,'Description',Edit3.text);
956 SetJsonparam(uploadparam,'Creation_Date',datetostr(now));
957 end
958 else begin
959 if questiondlg('Question','A previous upload was in progress, do you want to continue or abort it ?',mtcustom,[1,'Continue',2,'Abort'],'')=1 then
960 URL:=GetJSONparam(uploadparam,'URL');
961 end;
962
963 Res := Gdrivepost_resumable_file(URL, Data, ProgressBar1);
964 Memo1.Lines.Add(Res);
965
966 if copy(Res,1,3)='200' then deletefile(pchar(uploadparam));
967
968 end;
969
970 end;
971
972
973 finally
974 Data.Free;
975 gOAuth2.Free;
976 end;
977
978end;
979
980
981
982function TMainform.GetJSONParam(filename,param:string):string;
983var
984a: TJSONConfig;
985begin
986 a:= TJSONConfig.Create(nil);
987 try
988 a.Filename:=filename;
989 result:= a.GetValue(param,'');
990 finally
991 a.Free;
992 end;
993end;
994
995procedure TMainform.SetJSONParam(filename,param,value:string);
996var
997a: TJSONConfig;
998begin
999 a:= TJSONConfig.Create(nil);
1000 try
1001 a.Filename:=filename;
1002 a.SetValue(param,value);
1003 finally
1004 a.Free;
1005 end;
1006end;
1007
1008
1009
1010procedure TMainform.Button1Click(Sender: TObject);
1011begin;
1012end;
1013
1014end.