unit ulogin;
{$mode ObjFPC}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls,
LCLIntf, fphttpclient, fphttpserver, opensslsockets, fpjson, jsonparser,
URIParser, FileInfo;
type
{ TFrmlogin }
TFrmlogin = class(TForm)
BtnLogin: TButton;
lbl_version: TLabel;
MemoLog: TMemo;
procedure BtnLoginClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
FLocalServer: TFPHttpServer;
FAuthCode: string;
procedure OnRequest(Sender: TObject; var ARequest: TFPHTTPConnectionRequest;
var AResponse: TFPHTTPConnectionResponse);
function ExchangeCodeForToken(const Code: string): string;
function GetAppVersionString: string;
public
end;
var
Frmlogin: TFrmlogin;
const
GOOGLE_URL = 'https://accounts.google.com/o/oauth2/v2/auth?';
CLIENT_ID = 'xxxxxxxx';
CLIENT_SECRET = 'yyyyy';
// Choose a random high port for localhost redirect
REDIRECT_PORT = 8080;
REDIRECT_URI = 'http://localhost:8080/callback';
implementation
{$R *.lfm}
{ TFrmlogin }
procedure TFrmlogin.BtnLoginClick(Sender: TObject);
var
AuthURL: string;
begin
MemoLog.Lines.Add('Starting local listener...');
FAuthCode := '';
// 1. Set up a quick temporary server to listen for Google's callback
FLocalServer := TFPHttpServer.Create(nil);
try
FLocalServer.Active := False;
FLocalServer.Port := REDIRECT_PORT;
FLocalServer.OnRequest := @OnRequest;
try
MemoLog.Lines.Add('Before Active');
Application.ProcessMessages;
MemoLog.Lines.Add('Server before Started');
FLocalServer.Active := True;
FLocalServer.Threaded := True;
MemoLog.Lines.Add('Server Started');
except
on E: Exception do
MemoLog.Lines.Add(E.ClassName + ': ' + E.Message);
end;
//FLocalServer.Active := True; // Starts listening on background thread
// 2. Build the exact Google Auth Request URL
AuthURL :=
'https://accounts.google.com/o/oauth2/v2/auth?' + 'client_id=' +
CLIENT_ID + '&redirect_uri=' + REDIRECT_URI + '&response_type=code' +
'&scope=openid%20email%20profile' + '&access_type=offline' +
'&prompt=consent';
// Asking for basic user profile
MemoLog.Lines.Add('Opening browser for Google Login...');
// Open system browser (Cross-platform LCL function)
OpenURL(AuthURL);
// 3. Keep application processing alive until the server catches the code
while (FAuthCode = '') and (FLocalServer.Active) do
begin
Application.ProcessMessages;
Sleep(50);
end;
finally
FLocalServer.Active := False;
FLocalServer.Free;
end;
// 4. Once we have the authorization code, exchange it for tokens
if FAuthCode <> '' then
begin
MemoLog.Lines.Add('Auth code received. Exchanging for Access Token...');
ExchangeCodeForToken(FAuthCode);
end;
end;
procedure TFrmlogin.FormCreate(Sender: TObject);
begin
lbl_version.Caption := GetAppVersionString;
end;
procedure TFrmlogin.OnRequest(Sender: TObject; var ARequest: TFPHTTPConnectionRequest;
var AResponse: TFPHTTPConnectionResponse);
begin
if Pos('/callback', ARequest.URL) > 0 then
begin
// Extract the authorization code out of the URL query parameters
FAuthCode := ARequest.QueryFields.Values['code'];
// Respond back to the browser so the user sees a completion message
AResponse.ContentType := 'text/html; charset=utf-8';
AResponse.Content :=
'<h1>Login Successful!</h1><p>You can close this tab now and return to your app.</p>';
// Stop our temporary web server
FLocalServer.Active := False;
end;
end;
function TFrmlogin.ExchangeCodeForToken(const Code: string): string;
var
HTTP: TFPHTTPClient;
RawPayload, ResponseStr: string;
JSONData: TJSONData;
AccessToken: string;
begin
Result := '';
HTTP := TFPHTTPClient.Create(nil);
try
try
// Format parameters into standard x-www-form-urlencoded format
RawPayload := 'code=' + Code + '&client_id=' + CLIENT_ID +
'&client_secret=' + CLIENT_SECRET + '&redirect_uri=' +
REDIRECT_URI + '&grant_type=authorization_code';
HTTP.AddHeader('Content-Type', 'application/x-www-form-urlencoded');
// Prepare the client payload
HTTP.RequestBody := TStringStream.Create(RawPayload, TEncoding.UTF8);
// Exchange the authorization code at Google's endpoint
ResponseStr := HTTP.Post('https://oauth2.googleapis.com/token');
// Parse the returned JSON response safely
JSONData := GetJSON(ResponseStr);
try
if Assigned(JSONData.FindPath('access_token')) then
begin
AccessToken := JSONData.FindPath('access_token').AsString;
MemoLog.Lines.Add('Access Token obtained: ' +
Copy(AccessToken, 1, 15) + '...');
Result := AccessToken;
// Note: You can also extract an "id_token" which is a JWT containing name, email, and photo!
end
else
begin
MemoLog.Lines.Add('Failed to get token: ' + ResponseStr);
end;
finally
JSONData.Free;
end;
except
on E: Exception do
MemoLog.Lines.Add('Network Exception: ' + E.Message);
end;
finally
HTTP.RequestBody.Free;
HTTP.Free;
end;
end;
function TFrmlogin.GetAppVersionString: string;
var
FileVerInfo: TFileVersionInfo;
sVer: string;
begin
sVer := '1.0.0.0'; // Fallback default
FileVerInfo := TFileVersionInfo.Create(nil);
try
// Read the version data from the currently running executable
FileVerInfo.ReadFileInfo;
sVer := Format('%s', [FileVerInfo.VersionStrings[3]]);
Result := sVer;
finally
FileVerInfo.Free;
end;
end;
end.
Recent
