unit uTWAuth;
interface
uses
System.SysUtils, System.Classes, IdContext, IdCustomHTTPServer, IdHTTPServer,
IdComponent, winapi.ShellAPI, System.Threading, winapi.Windows;
type
TmyEvent = procedure(txt: string) of object;
type
TTTWAuth = class
FmyEvent: TmyEvent;
FURL: string;
private
FHTTPServer: TIdHTTPServer;
procedure HandleRequest(ASender: TIdContext;
ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
procedure HandleRootRequest(ARequestInfo: TIdHTTPRequestInfo;
AResponseInfo: TIdHTTPResponseInfo);
procedure HandleRedirectRequest(ARequestInfo: TIdHTTPRequestInfo;
AResponseInfo: TIdHTTPResponseInfo);
procedure HandleDARequest(ARequestInfo: TIdHTTPRequestInfo;
AResponseInfo: TIdHTTPResponseInfo);
procedure OnStatus(ASender: TObject; const AStatus: TIdStatus;
const AStatusText: string);
public
constructor Create;
destructor Destroy; override;
procedure StartServer(aURL: string);
procedure StopServer;
property OnToken: TmyEvent read FmyEvent write FmyEvent;
property OnError: TmyEvent read FmyEvent write FmyEvent;
end;
implementation
{ TTTWAuth }
constructor TTTWAuth.Create;
begin
inherited Create;
FHTTPServer := TIdHTTPServer.Create(nil);
FHTTPServer.OnCommandGet := HandleRequest;
FHTTPServer.OnStatus := OnStatus;
// Не включаем Active здесь
end;
destructor TTTWAuth.Destroy;
begin
try
if Assigned(FHTTPServer) then
begin
try
if FHTTPServer.Active then
FHTTPServer.Active := False;
except
end;
FreeAndNil(FHTTPServer);
end;
except
end;
inherited;
end;
procedure TTTWAuth.StartServer(aURL: string);
begin
// Защита от повторного запуска
if Assigned(FHTTPServer) and FHTTPServer.Active then
Exit;
// Очистим старые биндинги, чтобы не накапливать их
FHTTPServer.Bindings.Clear;
FHTTPServer.DefaultPort := 80;
// Добавляем биндинг явно
FHTTPServer.Bindings.Add.SetBinding('127.0.0.1', 80);
FURL := aURL;
FHTTPServer.Active := True;
if FURL <> '' then
ShellExecute(0, 'open', PWideChar(FURL), nil, nil, SW_SHOWNORMAL);
end;
procedure TTTWAuth.StopServer;
begin
if Assigned(FHTTPServer) then
begin
try
FHTTPServer.Active := False;
except
end;
try
FHTTPServer.Bindings.Clear;
except
end;
end;
end;
procedure TTTWAuth.HandleRequest(ASender: TIdContext;
ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
begin
if ARequestInfo.Document = '/' then
HandleRootRequest(ARequestInfo, AResponseInfo)
else if ARequestInfo.Document = '/redirect' then
HandleRedirectRequest(ARequestInfo, AResponseInfo)
else if ARequestInfo.Document = '/da' then
HandleDARequest(ARequestInfo, AResponseInfo)
else
begin
AResponseInfo.ResponseNo := 404;
AResponseInfo.ContentText := 'Not Found';
end;
end;
procedure TTTWAuth.HandleRootRequest(ARequestInfo: TIdHTTPRequestInfo;
AResponseInfo: TIdHTTPResponseInfo);
begin
AResponseInfo.ContentText := '' + sLineBreak + '' +
sLineBreak + '' + sLineBreak +
' Redirecting...' + sLineBreak + '' + sLineBreak +
'' + sLineBreak + ' получаю токен:
' + sLineBreak + '' + sLineBreak + '' + sLineBreak + '';
end;
procedure TTTWAuth.OnStatus(ASender: TObject; const AStatus: TIdStatus;
const AStatusText: string);
begin
// Можно логировать статус, но не обязательно
end;
procedure TTTWAuth.HandleDARequest(ARequestInfo: TIdHTTPRequestInfo;
AResponseInfo: TIdHTTPResponseInfo);
begin
AResponseInfo.ContentText := '' + sLineBreak + '' +
sLineBreak + '' + sLineBreak +
' Redirecting...' + sLineBreak + '' + sLineBreak +
'' + sLineBreak + ' получаю код
' + sLineBreak + '' + sLineBreak + '' + sLineBreak + '';
end;
procedure TTTWAuth.HandleRedirectRequest(ARequestInfo: TIdHTTPRequestInfo;
AResponseInfo: TIdHTTPResponseInfo);
var
i: Integer;
AccessToken: string;
LTokenCopy: string;
begin
// Если получен access_token
if Pos('access_token=', ARequestInfo.Params.Text) > 0 then
begin
for i := 0 to ARequestInfo.Params.Count - 1 do
if Pos('access_token', ARequestInfo.Params[i]) > 0 then
AccessToken := ARequestInfo.Params[i];
AccessToken := StringReplace(AccessToken, 'access_token=', '', [rfReplaceAll]);
AResponseInfo.ContentText := '' + sLineBreak + '' +
sLineBreak + '' + sLineBreak +
' Done...' + sLineBreak + '' + sLineBreak +
'' + sLineBreak + 'Эту страницу можно закрыть' + sLineBreak +
'' + sLineBreak + '';
AResponseInfo.WriteContent;
// Копируем токен, чтобы корректно передать в main thread
LTokenCopy := AccessToken;
// Вызываем OnToken в main thread
if Assigned(FmyEvent) then
TThread.Queue(nil,
procedure
begin
try
FmyEvent(LTokenCopy);
except
end;
end);
// Остановим сервер и запланируем очистку объекта в main thread
try
StopServer;
except
end;
TThread.Queue(nil,
procedure
begin
try
Free;
except
end;
end);
Exit;
end;
// Если есть error_description
if Pos('error_description=', ARequestInfo.Params.Text) > 0 then
begin
for i := 0 to ARequestInfo.Params.Count - 1 do
if Pos('error_description', ARequestInfo.Params[i]) > 0 then
AccessToken := ARequestInfo.Params[i];
AccessToken := StringReplace(AccessToken, 'error_description=', '', [rfReplaceAll]);
AResponseInfo.ContentText := '' + sLineBreak + '' +
sLineBreak + '' + sLineBreak +
' ERROR...' + sLineBreak + '' + sLineBreak +
'' + sLineBreak + AccessToken + sLineBreak + '' + sLineBreak + '';
AResponseInfo.WriteContent;
LTokenCopy := AccessToken;
if Assigned(FmyEvent) then
TThread.Queue(nil,
procedure
begin
try
FmyEvent(LTokenCopy);
except
end;
end);
try
StopServer;
except
end;
TThread.Queue(nil,
procedure
begin
try
Free;
except
end;
end);
Exit;
end;
// Если получен code=
if Pos('code=', ARequestInfo.Params.Text) > 0 then
begin
for i := 0 to ARequestInfo.Params.Count - 1 do
if Pos('code', ARequestInfo.Params[i]) > 0 then
AccessToken := ARequestInfo.Params[i];
AccessToken := StringReplace(AccessToken, 'code=', '', [rfReplaceAll]);
AResponseInfo.ContentText := '' + sLineBreak + '' +
sLineBreak + '' + sLineBreak +
' Done...' + sLineBreak + '' + sLineBreak +
'' + sLineBreak + 'Эту страницу можно закрыть' + sLineBreak +
'' + sLineBreak + '';
AResponseInfo.WriteContent;
LTokenCopy := AccessToken;
if Assigned(FmyEvent) then
TThread.Queue(nil,
procedure
begin
try
FmyEvent(LTokenCopy);
except
end;
end);
try
StopServer;
except
end;
TThread.Queue(nil,
procedure
begin
try
Free;
except
end;
end);
Exit;
end;
// По умолчанию — 404
AResponseInfo.ResponseNo := 404;
AResponseInfo.ContentText := 'Not Found';
AResponseInfo.WriteContent;
end;
end.