unit uTWAuth;

interface

uses
  System.SysUtils, System.Classes, IdContext, IdCustomHTTPServer, IdHTTPServer,
  IdComponent, ShellAPI, System.Threading, 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 := '<!DOCTYPE html>' + sLineBreak + '<html>' +
    sLineBreak + '<head>' + sLineBreak +
    '  <title>Redirecting...</title>' + sLineBreak + '</head>' + sLineBreak +
    '<body>' + sLineBreak + ' <p>получаю токен:</p>' + sLineBreak + '<script>' +
    sLineBreak + 'var paragraph = window.location.href;' + sLineBreak +
    'var urrl = paragraph.replace(''localhost/'',''localhost/redirect'');' +
    sLineBreak + 'urrl = urrl.replace(''#'',''?'');' + sLineBreak +
    'console.log(urrl);' + sLineBreak + 'window.location.href =urrl;' +
    sLineBreak + '	</script>' + sLineBreak + '</body>' + sLineBreak + '</html>';
end;

procedure TTTWAuth.OnStatus(ASender: TObject; const AStatus: TIdStatus;
  const AStatusText: string);
begin
  // Можно логировать статус, но не обязательно
end;

procedure TTTWAuth.HandleDARequest(ARequestInfo: TIdHTTPRequestInfo;
  AResponseInfo: TIdHTTPResponseInfo);
begin
  AResponseInfo.ContentText := '<!DOCTYPE html>' + sLineBreak + '<html>' +
    sLineBreak + '<head>' + sLineBreak +
    '  <title>Redirecting...</title>' + sLineBreak + '</head>' + sLineBreak +
    '<body>' + sLineBreak + ' <p>получаю код</p>' + sLineBreak + '<script>' +
    sLineBreak + 'var paragraph = window.location.href;' + sLineBreak +
    'var urrl = paragraph.replace(''localhost/da'',''localhost/redirect'');' +
    sLineBreak + 'urrl = urrl.replace(''#'',''?'');' + sLineBreak +
    'console.log(urrl);' + sLineBreak + 'window.location.href =urrl;' +
    sLineBreak + '	</script>' + sLineBreak + '</body>' + sLineBreak + '</html>';
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 := '<!DOCTYPE html>' + sLineBreak + '<html>' +
      sLineBreak + '<head>' + sLineBreak +
      '  <title>Done...</title>' + sLineBreak + '</head>' + sLineBreak +
      '<body>' + sLineBreak + 'Эту страницу можно закрыть' + sLineBreak +
      '</body>' + sLineBreak + '</html>';
    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 := '<!DOCTYPE html>' + sLineBreak + '<html>' +
      sLineBreak + '<head>' + sLineBreak +
      '  <title>ERROR...</title>' + sLineBreak + '</head>' + sLineBreak +
      '<body>' + sLineBreak + AccessToken + sLineBreak + '</body>' + sLineBreak + '</html>';
    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 := '<!DOCTYPE html>' + sLineBreak + '<html>' +
      sLineBreak + '<head>' + sLineBreak +
      '  <title>Done...</title>' + sLineBreak + '</head>' + sLineBreak +
      '<body>' + sLineBreak + 'Эту страницу можно закрыть' + sLineBreak +
      '</body>' + sLineBreak + '</html>';
    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.

