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