ChatGPT API с Delphi FMX/VCL: надёжная интеграция с потоковой передачей, повторными попытками и корректным разбором JSON

unit Net-Base.OpenAI.ChatClient;

interface

uses
  System.SysUtils, System.Classes, System.Net.URLClient, System.Net.HttpClient,
  System.Net.HttpClientComponent, System.JSON, System.Threading,
  System.SyncObjs;

type
  EChatApiError = class(Exception)
  private
    FHttpStatus: Integer;
    FResponseText: string;
  public
    constructor Create(const Msg: string; AHttpStatus: Integer; const AResponseText: string);
    property HttpStatus: Integer read FHttpStatus;
    property ResponseText: string read FResponseText;
  end;

  TChatStreamEvent = reference to procedure(const AChunkText: string; AIsFinal: Boolean);

  TChatCompletionOptions = record
    Model: string;
    Temperature: Double;
    MaxTokens: Integer;
    constructor Create(const AModel: string; ATemperature: Double = 0.2; AMaxTokens: Integer = 512);
  end;

  TOpenAIChatClient = class
  private
    FBaseUrl: string;
    FApiKey: string;
    FConnectTimeoutMs: Integer;
    FResponseTimeoutMs: Integer;

    function BuildChatRequestBody(const AUserPrompt: string; const AOptions: TChatCompletionOptions;
      AStream: Boolean): TJSONObject;

    function ExtractTextFromNonStreamingResponse(const AJsonText: string): string;
    function TryExtractErrorMessage(const AJsonText: string; out AMessage: string): Boolean;

    procedure ApplyAuthHeaders(ARequest: IHTTPRequest);

    function ExecuteWithRetry(const ADoRequest: TFunc): IHTTPResponse;
  public
    constructor Create(const ABaseUrl, AApiKey: string);

    property ConnectTimeoutMs: Integer read FConnectTimeoutMs write FConnectTimeoutMs;
    property ResponseTimeoutMs: Integer read FResponseTimeoutMs write FResponseTimeoutMs;

    function ChatOnce(const AUserPrompt: string; const AOptions: TChatCompletionOptions): string;

    procedure ChatStream(const AUserPrompt: string; const AOptions: TChatCompletionOptions;
      const AOnEvent: TChatStreamEvent);
  end;

implementation

{ EChatApiError }

constructor EChatApiError.Create(const Msg: string; AHttpStatus: Integer; const AResponseText: string);
begin
  inherited Create(Msg);
  FHttpStatus := AHttpStatus;
  FResponseText := AResponseText;
end;

{ TChatCompletionOptions }

constructor TChatCompletionOptions.Create(const AModel: string; ATemperature: Double; AMaxTokens: Integer);
begin
  Model := AModel;
  Temperature := ATemperature;
  MaxTokens := AMaxTokens;
end;

{ TOpenAIChatClient }

constructor TOpenAIChatClient.Create(const ABaseUrl, AApiKey: string);
begin
  inherited Create;
  FBaseUrl := ABaseUrl.TrimRight(['/']);
  FApiKey := AApiKey;
  FConnectTimeoutMs := 8000;
  FResponseTimeoutMs := 60000;
end;

procedure TOpenAIChatClient.ApplyAuthHeaders(ARequest: IHTTPRequest);
begin
  // Bearer Token: здесь API-ключ как „Authorization: Bearer …“.
  // В корпоративной среде дополнительно следите за тем, чтобы ключи не попали в логи.
  ARequest.AddHeader('Authorization', 'Bearer ' + FApiKey);
  ARequest.AddHeader('Content-Type', 'application/json');
  ARequest.AddHeader('Accept', 'application/json');
end;

function TOpenAIChatClient.BuildChatRequestBody(const AUserPrompt: string;
  const AOptions: TChatCompletionOptions; AStream: Boolean): TJSONObject;
var
  Msgs: TJSONArray;
  Msg: TJSONObject;
begin
  Result := TJSONObject.Create;
  Result.AddPair('model', AOptions.Model);
  Result.AddPair('temperature', TJSONNumber.Create(AOptions.Temperature));
  Result.AddPair('max_tokens', TJSONNumber.Create(AOptions.MaxTokens));
  Result.AddPair('stream', TJSONBool.Create(AStream));

  // Минимальная структура messages (Chat Completions): role/content.
  Msgs := TJSONArray.Create;
  Msg := TJSONObject.Create;
  Msg.AddPair('role', 'user');
  Msg.AddPair('content', AUserPrompt);
  Msgs.AddElement(Msg);
  Result.AddPair('messages', Msgs);
end;

function TOpenAIChatClient.TryExtractErrorMessage(const AJsonText: string; out AMessage: string): Boolean;
var
  J: TJSONValue;
  EObj: TJSONObject;
begin
  Result := False;
  AMessage := '';

  J := TJSONObject.ParseJSONValue(AJsonText);
  try
    if (J is TJSONObject) then
    begin
      // Частая форма: { "error": { "message": "...", "type": "..." } }
      EObj := (J as TJSONObject).GetValue<TJSONObject>('error');
      if Assigned(EObj) then
      begin
        AMessage := EObj.GetValue<string>('message', '');
        Result := AMessage <> '';
      end;
    end;
  finally
    J.Free;
  end;
end;

function TOpenAIChatClient.ExtractTextFromNonStreamingResponse(const AJsonText: string): string;
var
  J: TJSONValue;
  Root: TJSONObject;
  Choices: TJSONArray;
  Choice0: TJSONObject;
  Msg: TJSONObject;
begin
  Result := '';

  J := TJSONObject.ParseJSONValue(AJsonText);
  try
    if not (J is TJSONObject) then
      raise EChatApiError.Create('Неожиданный JSON-ответ (не объект).', 0, AJsonText);

    Root := J as TJSONObject;
    Choices := Root.GetValue<TJSONArray>('choices');
    if (Choices = nil) or (Choices.Count = 0) then
      raise EChatApiError.Create('Неожиданный JSON-ответ: поле choices отсутствует или пусто.', 0, AJsonText);

    Choice0 := Choices.Items[0] as TJSONObject;
    // Chat Completions: choices[0].message.content
    Msg := Choice0.GetValue<TJSONObject>('message');
    if Msg = nil then
      raise EChatApiError.Create('Неожиданный JSON-ответ: отсутствует поле message.', 0, AJsonText);

    Result := Msg.GetValue<string>('content', '');
  finally
    J.Free;
  end;
end;

function TOpenAIChatClient.ExecuteWithRetry(const ADoRequest: TFunc<IHTTPResponse>): IHTTPResponse;
const
  MaxAttempts = 3;
var
  Attempt: Integer;
  DelayMs: Integer;
begin
  DelayMs := 350;
  for Attempt := 1 to MaxAttempts do
  begin
    try
      Exit(ADoRequest());
    except
      on E: ENetHTTPClientException do
      begin
        // Сетевые/TLS/таймаут-ошибки: простой повтор с увеличением задержки (backoff).
        if Attempt = MaxAttempts then
          raise;
        Sleep(DelayMs);
        DelayMs := DelayMs * 2;
      end;
    end;
  end;
  Result := nil;
end;

function TOpenAIChatClient.ChatOnce(const AUserPrompt: string; const AOptions: TChatCompletionOptions): string;
var
  Http: THTTPClient;
  Req: IHTTPRequest;
  Resp: IHTTPResponse;
  Body: TJSONObject;
  Payload: TStringStream;
  RespText: string;
  ErrMsg: string;
begin
  Http := THTTPClient.Create;
  try
    Http.ConnectionTimeout := FConnectTimeoutMs;
    Http.ResponseTimeout := FResponseTimeoutMs;

    Body := BuildChatRequestBody(AUserPrompt, AOptions, False);
    try
      Payload := TStringStream.Create(Body.ToJSON, TEncoding.UTF8);
      try
        Req := Http.GetRequest('POST', FBaseUrl + '/v1/chat/completions');
        ApplyAuthHeaders(Req);

        Resp := ExecuteWithRetry(
          function: IHTTPResponse
          begin
            Result := Http.Execute(Req, Payload);
          end
        );

        RespText := Resp.ContentAsString(TEncoding.UTF8);

        if (Resp.StatusCode < 200) or (Resp.StatusCode >= 300) then
        begin
          if TryExtractErrorMessage(RespText, ErrMsg) then
            raise EChatApiError.Create(ErrMsg, Resp.StatusCode, RespText)
          else
            raise EChatApiError.Create('HTTP-ошибка ' + Resp.StatusCode.ToString, Resp.StatusCode, RespText);
        end;

        Result := ExtractTextFromNonStreamingResponse(RespText);
      finally
        Payload.Free;
      end;
    finally
      Body.Free;
    end;
  finally
    Http.Free;
  end;
end;

procedure TOpenAIChatClient.ChatStream(const AUserPrompt: string; const AOptions: TChatCompletionOptions;
  const AOnEvent: TChatStreamEvent);
var
  Task: ITask;
begin
  // Запуск стриминга намеренно выполняется асинхронно, чтобы FMX/VCL не блокировались.
  Task := TTask.Run(
    procedure
    var
      Http: THTTPClient;
      Req: IHTTPRequest;
      Resp: IHTTPResponse;
      Body: TJSONObject;
      Payload: TStringStream;
      Stream: TStream;
      Reader: TStreamReader;
      Line, Data: string;
      J: TJSONValue;
      Delta, Choice0, Choices: TJSONValue;
      ContentChunk: string;
    begin
      Http := THTTPClient.Create;
      try
        Http.ConnectionTimeout := FConnectTimeoutMs;
        Http.ResponseTimeout := FResponseTimeoutMs;

        Body := BuildChatRequestBody(AUserPrompt, AOptions, True);
        try
          Payload := TStringStream.Create(Body.ToJSON, TEncoding.UTF8);
          try
            Req := Http.GetRequest('POST', FBaseUrl + '/v1/chat/completions');
            ApplyAuthHeaders(Req);
            Req.AddHeader('Accept', 'text/event-stream');

            Resp := ExecuteWithRetry(
              function: IHTTPResponse
              begin
                Result := Http.Execute(Req, Payload);
              end
            );

            if (Resp.StatusCode < 200) or (Resp.StatusCode >= 300) then
            begin
              // При ошибках стриминга содержимое часто всё равно в формате JSON.
              TThread.Queue(nil,
                procedure
                begin
                  AOnEvent('Запуск стриминга не удался (HTTP ' + Resp.StatusCode.ToString + ').', True);
                end);
              Exit;
            end;

            Stream := Resp.ContentStream;
            Reader := TStreamReader.Create(Stream, TEncoding.UTF8, True, 4096, False);
            try
              while not Reader.EndOfStream do
              begin
                Line := Reader.ReadLine;
                if Line = '' then
                  Continue;

                // Формат SSE: строки вида "data: {...}" или "data: [DONE]"
                if Line.StartsWith('data:') then
                begin
                  Data := Line.Substring(5).Trim;
                  if SameText(Data, '[DONE]') then
                  begin
                    TThread.Queue(nil,
                      procedure
                      begin
                        AOnEvent('', True);
                      end);
                    Break;
                  end;

                  // Анализ JSON-чанка: choices[0].delta.content
                  J := TJSONObject.ParseJSONValue(Data);
                  try
                    ContentChunk := '';
                    if J <> nil then
                    begin
                      Choices := (J as TJSONObject).GetValue('choices');
                      if (Choices is TJSONArray) and (TJSONArray(Choices).Count > 0) then
                      begin
                        Choice0 := TJSONArray(Choices).Items[0];
                        Delta := (Choice0 as TJSONObject).GetValue('delta');
                        if (Delta is TJSONObject) then
                          ContentChunk := TJSONObject(Delta).GetValue<string>('content', '');
                      end;
                    end;
                  finally
                    J.Free;
                  end;

                  if ContentChunk <> '' then
                    TThread.Queue(nil,
                      procedure
                      begin
                        AOnEvent(ContentChunk, False);
                      end);
                end;
              end;
            finally
              Reader.Free;
            end;
          finally
            Payload.Free;
          end;
        finally
          Body.Free;
        end;
      finally
        Http.Free;
      end;
    end);
end;

end.