Delphi 2007 TIDHttp HTTPS 出现Error connecting with SSL

最新推荐文章于 2022-01-04 17:33:51 发布

ceaningking

最新推荐文章于 2022-01-04 17:33:51 发布

阅读量4.5k

点赞数 2

分类专栏： Delphi

本文链接：https://blog.csdn.net/ceaningking/article/details/110236026

版权

Delphi 专栏收录该内容

24 篇文章 7 订阅

订阅专栏

在Delphi 2007上的程序，曾经对接过好几个Https类型的支付平台，一直都很正常。

可是最近对接的一个https类型的平台，总是出现Error connecting with SSL，使用PostMan工具请求正常，但是程序请求不正常。

在网上找不到解决办法，各项配置确认配置正确。于是使用Delphi XE10.1写了一个Demo，进行请求，竟然通讯正常，于是使用XE10.1封装一个Https的dll，给程序调用.

1. 工程文件

library httpstool;

uses
  System.SysUtils,
  System.Classes,
  unt_objects in 'public\unt_objects.pas',
  uPub in 'public\uPub.pas',
  InterfaceDll in 'public\InterfaceDll.pas';

{$R *.res}

exports
  dll_init,
  dll_post,
  dll_get,
  dll_uninit;

begin
end.

2. unt_objects单元

unit unt_objects;

interface

uses
  IdHTTP, IdSSLOpenSSL, System.SysUtils, System.Classes, System.IniFiles,
  System.StrUtils, Winapi.Windows;

const
  ini_file= 'set.ini';

  Err_01= '配置文件[set.ini]缺失...';
  Err_02= '创建对象失败...';

type
  TTools= class
  private
    FDebug    : Boolean;           //调试模式
    FHttps    : TIdHTTP;
    FIdSSL    : TIdSSLIOHandlerSocketOpenSSL;
    //FHttps 参数信息
    FHandleRedirects: Boolean;
    FProtocolVersion: Integer;
    FAccept: string;
    FAcceptEncoding: string;
    FContentType: string;
    FConnection: string;
    FReadTimeout: Integer;
    FConnectTimeout: Integer;
    //FIdSSL 参数信息
    FMethod   : Integer;
    FMode     : Integer;

    FParams: TStringList;
  published
    property _debug: Boolean read FDebug write FDebug;
    property _Https: TIdHTTP read FHttps write FHttps;
    property _params: TStringList read FParams write FParams;
  public
    constructor Create();
    destructor Destroy; override;
    //读取本地参数
    function ReadLocalParams: Boolean;
    //发送Post请求
    function SendPost(sUrl: PAnsiChar; lst: TStringList; var sOut, sErr: PAnsiChar): Byte;
    //发送Get请求
    function SendGet(sUrl: PAnsiChar; lst: TStringList; var sOut, sErr: PAnsiChar): Byte;
  end;

implementation

uses uPub;

{ TTools }

constructor TTools.Create;
begin
  FParams:= TStringList.Create;
  if ReadLocalParams then
  begin
    FHttps  := Tidhttp.Create(nil);
    FHttps.HTTPOptions := [];          //关键参数， 关系到编码自动转换
    FHttps.HandleRedirects:= True;
    case FProtocolVersion of
      0: FHttps.ProtocolVersion:= pv1_0;
      1: FHttps.ProtocolVersion:= pv1_1;
    else
      FHttps.ProtocolVersion:= pv1_1;
    end;
    FHttps.HTTPOptions := [];
    FHttps.ProtocolVersion:= pv1_1;
    FHttps.Request.Accept:= FAccept;
    FHttps.Request.AcceptEncoding:= FAcceptEncoding;
    FHttps.Request.ContentType:= FContentType;
    FHttps.Request.Connection:= FConnection;
    FHttps.ReadTimeout:= FReadTimeout* 1000;
    FHttps.ConnectTimeout:= FConnectTimeout* 1000;

    FIdSSL  := TIdSSLIOHandlerSocketOpenSSL.Create(nil);
    FIdSSL.SSLOptions.Method:= sslvSSLv23;
    FIdSSL.SSLOptions.Mode:= sslmClient;
    case FMethod of
      0: FIdSSL.SSLOptions.Method:= sslvSSLv2;
      1: FIdSSL.SSLOptions.Method:= sslvSSLv23;
      2: FIdSSL.SSLOptions.Method:= sslvSSLv3;
      3: FIdSSL.SSLOptions.Method:= sslvTLSv1;
      4: FIdSSL.SSLOptions.Method:= sslvTLSv1_1;
      5: FIdSSL.SSLOptions.Method:= sslvTLSv1_2;
    else
      FIdSSL.SSLOptions.Method:= sslvTLSv1
    end;
    case FMode of
      0: FIdSSL.SSLOptions.Mode:= sslmUnassigned;
      1: FIdSSL.SSLOptions.Mode:= sslmClient;
      2: FIdSSL.SSLOptions.Mode:= sslmServer;
      3: FIdSSL.SSLOptions.Mode:= sslmBoth;
    else
      FIdSSL.SSLOptions.Mode:= sslmUnassigned;
    end;

    FHttps.IOHandler:= FIdSSL;
  end
  else
    systemLog(Err_02);
end;

destructor TTools.Destroy;
begin
  if Assigned(FHttps) then
    FreeAndNil(FHttps);
  if Assigned(FParams) then
    FreeAndNil(FParams);
//  if Assigned(FIDSSL) then
//    FreeAndNil(FIdSSL);
  inherited;
end;

function TTools.ReadLocalParams: Boolean;
var
  sIni: TIniFile;
  filename: string;
begin
  Result:= False;
  filename:= TFilePath.IniFile;
  if not FileExists(filename) then
  begin
    systemLog(Err_01);
    Exit;
  end;
  sIni:= TIniFile.Create(filename);
  try
    FDebug:= sIni.ReadBool('RunMode', 'Debug', True);

    FHandleRedirects:= sIni.ReadBool('IDHTTP', 'HandleRedirects', False);
    FProtocolVersion:= sIni.ReadInteger('IDHTTP', 'HandleRedirects', 1);
    FAccept:= sIni.ReadString('IDHTTP', 'Accept', '*/*');
    FAcceptEncoding:= sIni.ReadString('IDHTTP', 'AcceptEncoding', 'gzip, deflate, br');
    FContentType:= sIni.ReadString('IDHTTP', 'ContentType', 'application/x-www-form-urlencoded');
    FConnection:= sIni.ReadString('IDHTTP', 'Connection', 'close');
    FReadTimeout:= sIni.ReadInteger('IDHTTP', 'ReadTimeout', 5);
    FConnectTimeout:= sIni.ReadInteger('IDHTTP', 'ConnectTimeout', 5);

    FMethod:= sIni.ReadInteger('IDSSL', 'Method', 3);  //默认sslvTLSv1
    FMode:= sIni.ReadInteger('IDSSL', 'Mode', 0);      //默认sslmUnassigned
    Result:= True;
  finally
    FreeAndNil(sIni);
  end;
end;

function TTools.SendGet(sUrl: PAnsiChar; lst: TStringList;
  var sOut, sErr: PAnsiChar): Byte;
var
  I: Integer;
  URL: string;
  responseStream: TStringStream;
begin
  Result:= 0;
  sOut:= '';
  sErr:= '';
  //拼接URL字符串
  if lst.Count> 0 then
    URL:= sUrl+ '?'
  else
    URL:= sUrl;
  for I := 0 to lst.Count- 1 do
  begin
    if I<> lst.Count- 1 then
      URL:= URL+ lst[I]+ '&'
    else
      URL:= URL+ lst[I];
  end;

  if _Https.Connected then
    _Https.Disconnect;
  responseStream:= TStringStream.Create('');
  try
    try
      if _debug then
        systemLog('Snd: '+ URL);
      _Https.Get(URL, responseStream);
      sOut:= PAnsiChar(AnsiString(UTF8Decode(responseStream.DataString)));
      if _debug then
        systemLog('Rcv: '+ sOut);
      Result:= 1;
    except
      on e: Exception do
      begin
        sErr:= PAnsiChar(e.Message);
        systemLog(e.Message);
      end;
    end;
  finally
    if _Https.Connected then
      _Https.Disconnect;
    FreeAndNil(responseStream);
  end;
end;

function TTools.SendPost(sUrl: PAnsiChar; lst: TStringList;
  var sOut, sErr: PAnsiChar): Byte;
var
  URL: string;
begin
  Result:= 0;
  sOut:= '';
  sErr:= '';
  URL:= sUrl;
  if FHttps.Connected then
    FHttps.Disconnect;
  try
    try
      if _debug then
        systemLog('Snd: '+ sUrl);
      sOut:= PAnsiChar(AnsiString(FHttps.Post(URL, lst)));
      if _debug then
        systemLog('Rcv: '+ sOut);
      Result:= 1;
    except
      on e: Exception do
      begin
        sErr:= PAnsiChar(e.Message);
        systemLog(e.Message);
      end;
    end;
  finally
    if FHttps.Connected then
      FHttps.Disconnect;
  end;
end;

end.

3. uPub单元

unit uPub;

interface

uses
  System.SysUtils, System.Classes, superobject, qjson;

type
  TAppPara = class
  public
    class function AppPath: string;
    class function AppName: string;
  end;

  TFilePath = class(TAppPara)
  public
    class function IniFile: string;
  end;

//写日志
procedure systemLog(Msg: AnsiString);

//json转list
procedure JsonToList(sJson: AnsiString; var lst: TStringList);

implementation

procedure systemLog(Msg: AnsiString);
var
  F: TextFile;
  FileName: string;
  ExeRoad: string;
begin
  try
    ExeRoad := ExtractFilePath(ParamStr(0));
    if ExeRoad[Length(ExeRoad)] = '\' then
      SetLength(ExeRoad, Length(ExeRoad) - 1);
    if not DirectoryExists(ExeRoad + 'log') then
    begin
      CreateDir(ExeRoad + '\log');
    end;
    FileName := ExeRoad + '\log\_Log' + FormatDateTime('YYMMDD', NOW) + '.txt';
    if not FileExists(FileName) then
    begin
      AssignFile(F, FileName);
      ReWrite(F);
    end
    else
      AssignFile(F, FileName);
    Append(F);
    Writeln(F, FormatDateTime('HH:NN:SS.zzz ', Now) + Msg);
    CloseFile(F);
  except
    //可能在事务中调用,避免意外
    Exit;
  end;
end;

procedure JsonToList(sJson: AnsiString; var lst: TStringList);
var
  I: Integer;
  json: ISuperObject;
  jsonArr: TSuperArray;
  sValue: AnsiString;
  str: string;
  js: TQjson;
begin
  lst.Clear;
  try
    str:= json.AsString;
    jsonArr:= json.O['params'].AsArray;
    for I := 0 to jsonArr.Length- 1 do
    begin
      sValue:= jsonArr.O[I].S['param'];
      if sValue<> '' then
        lst.Add(sValue)
    end;
  except
    on e: Exception do
      systemLog('[JsonToList] Err:'+ sJson);
  end;
end;

{ TAppPara }

class function TAppPara.AppName: string;
begin
  Result := ExtractFileName(ParamStr(0));
end;

class function TAppPara.AppPath: string;
begin
  Result := ExtractFilePath(ParamStr(0));
end;

{ TFilePath }

class function TFilePath.IniFile: string;
begin
  Result := AppPath + 'set.ini';
end;

end.

4. InterfaceDll单元

unit InterfaceDll;

interface

uses
  unt_objects, Winapi.Windows, System.SysUtils, System.Classes;

var
  tool: TTools;

//初始化
function dll_init: Byte; stdcall;
//Post
function dll_post(sUrl, sJson: PAnsiChar; var sOut, sErr: PAnsiChar): Byte; stdcall;
//Get
function dll_get(sUrl, sJson: PAnsiChar; var sOut, sErr: PAnsiChar): Byte; stdcall;
//释放
function dll_uninit: Byte; stdcall;

implementation

uses uPub;

//初始化
function dll_init: Byte;
begin
  Result:= 0;
  if not Assigned(tool) then
    tool:= TTools.Create;
  Result:= 1;
end;

//Post
function dll_post(sUrl, sJson: PAnsiChar; var sOut, sErr: PAnsiChar): Byte;
var
  lst: TStringList;
begin
  Result:= 0;
  if Assigned(tool) then
  begin
    if tool._debug then
      systemLog('[dll_post]: '+ sJson);
    lst:= TStringList.Create;
    try
      lst.Text:= sJson;
      Result:= tool.SendPost(sUrl, lst, sOut, sErr);
    finally
      FreeAndNil(lst);
    end;
  end
  else
  begin
    systemLog('[dll_post]: '+ Err_02);
    Exit;
  end;
end;

//Get
function dll_get(sUrl, sJson: PAnsiChar; var sOut, sErr: PAnsiChar): Byte;
var
  lst: TStringList;
begin
  Result:= 0;
  if Assigned(tool) then
  begin
    lst:= TStringList.Create;
    try
      JsonToList(sJson, lst);
      Result:= tool.SendGet(sUrl, lst, sOut, sErr);
    finally
      FreeAndNil(lst);
    end;
  end
  else
  begin
    systemLog('[dll_get]: '+ Err_02);
    Exit;
  end;
end;

//释放
function dll_uninit: Byte;
begin
  result:= 0;
  if Assigned(tool) then
    FreeAndNil(tool);
  result:= 1;
end;

end.

5. set.ini参考如下

[RunMode]
Debug=0

[IDHTTP]
HandleRedirects=0
ProtocolVersion=1
Accept=*/*
AcceptEncoding=gzip, deflate, br
ContentType=application/x-www-form-urlencoded
Connection=close
ReadTimeout=5
ConnectTimeout=5

[IDSSL]
Method=1
Mode=1

使用Delphi 2007 Demo程序调用

1. 引入dll接口

unit uHttpsTool;

interface

uses
  Classes;

const
  dllName= 'httpstool.dll';

  function dll_init: Byte; stdcall; external dllName;

  function dll_post(sUrl, sJson: PChar; var sOut, sErr: PChar): Byte; stdcall; external dllName;

  function dll_get(sUrl, sJson: PChar; var sOut, sErr: PChar): Byte; stdcall; external dllName;

  function dll_uninit: Byte; stdcall; external dllName;

implementation

end.

2. 界面单元

unit uFrmMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses uHttpsTool, superobject;

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
  sUrl, sOut, sErr, sjson: PChar;
  json: ISuperObject;
  iRet: Byte;
begin
  sUrl:= 'https://********/leavePlatform/getLeaveInfo';
//  json:= SO();
//  json['params']:= SA([]);
//  json.A['params'].Add(SO(Format(ftFmt, ['serialType=1'])));
//  json.A['params'].Add(SO(Format(ftFmt, ['serialValue=123456'])));
  sjson:= 'serialType=1'+ #13#10+ 'serialValue=123456';
  try
    iRet:= dll_post(sUrl, sjson, sOut, sErr);
    ShowMessage(sOut);
  except
    on e: Exception do
      ShowMessage(e.Message);
  end;
end;

procedure TForm1.Button3Click(Sender: TObject);
var
  iRet: Byte;
begin
  iRet:= dll_init;
  if iRet= 1 then
    ShowMessage('Success')
  else
    ShowMessage('Fail');
end;

procedure TForm1.Button4Click(Sender: TObject);
var
  iRet: Byte;
begin
  iRet:= dll_uninit;
  if iRet= 1 then
    ShowMessage('Success')
  else
    ShowMessage('Fail');
end;

end.

可能有其它的解决方案，这篇文章仅作参考。

ceaningking

关注

2
点赞
踩
3

收藏

觉得还不错? 一键收藏
4
评论
Delphi 2007 TIDHttp HTTPS 出现Error connecting with SSL

在Delphi 2007上的程序，曾经对接过好几个Https类型的支付平台，一直都很正常。可是最近对接的一个https类型的平台，总是出现Error connecting with SSL，使用PostMan工具请求正常，但是程序请求不正常。在网上找不到解决办法，各项配置确认配置正确。于是使用Delphi XE10.1写了一个Demo，进行请求，竟然通讯正常，于是使用XE10.1封装一个Https的dll，给程序调用.1. 工程文件library httpstool;uses Sy
复制链接

扫一扫