在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.
可能有其它的解决方案,这篇文章仅作参考。