Measure/DataModules/PHPWebDm.pas

{*******************************************************************************
    单元名称： PHPWebDm.pas

    单元说明： Delphi 同PHP web服务器通信接口。 计量的PHP比造价的PHP多了很多

    作者时间： Chenshilong, 2012-5-13
*******************************************************************************}


unit PHPWebDm;

interface

uses
  SysUtils, Classes, IdBaseComponent, IdComponent, IdTCPConnection,
  IdTCPClient, IdHTTP, CslJson;

type
  // Web连接成功、Web连接失败、登录失败、旧用户需要升级、资料不全
  TLoginType = (ltCon, ltDisCon, ltLoginFail, ltUpdate, ltIncomplete);

  TPHPWeb = class(TDataModule)
    IdHTTP: TIdHTTP;
    procedure DataModuleCreate(Sender: TObject);
  private
    // 远程服务器上时间
    FServerDateTime: TDateTime;
    FUserID: Integer;
    FAccount: string;
    FRealName: string;
    FUserFlag: Integer; // 用户标志位，用于区分出一部分用户进行特殊控制。
    FMeasureURL: string;  // http://d.jl.smartcost.com.cn/api/client/
    FLoginURL: string;
    FLoginBannerURL: string;
    FCheckOnLineURL: string;
    FPassportURL: string;
    FPwdURL: string;
    FRegURL: string;
    FWebLoginURL: string;
    FServerDateTimeURL: string;
    FWebSoftURL: string;
    FLogoutURL: string;
    FRole: string;
    FCompany: string;
    FUserImageURL: string;
    FLoginCloudURL: string;

    procedure SetUserID(const Value: Integer);
    procedure SetAccount(const Value: string);
    procedure SetRealName(const Value: string);

{-------------------------------------------------------------------------------
  方法:   CustomSearch()

  描述:   通用的查询接口，集各种复杂情况之大成，宇宙级牛B综合算法，哦耶！ ^__^

          【函数返回值】
            -1：           网络不通；
             0：           网络通，但登录或查询出错、网页出错等，无法返回约定的
                           Json格式，通常返回一篇乱码；
             1：           成功(包括返回零记录)

          【参数】
             AURL：        请求的网址。
             AInFields：   请求的键名字。
             AInValues：   请求的键值。
             AResultType： 返回值类型：0 返回一维数组；1 返回二维数组；2 两者都。
             AOutStrs：    用于存储返回的零散值。需要赋字段名传入。
             AOutRecords： 用于存储返回的多条记录、数据表。只需声明，无需定义大
                           小和赋值，返回Json的数组，数组的值为'info'对象的值。

          【要求】
             ①返回的Json数据中必须有status、msg两个键名字（约定格式）。
             ②AResults至少有一个元素，用来存储当返回值为0时查询出错的原因。


  作者:   Chenshilong, 2014-07-13
-------------------------------------------------------------------------------}
    function CustomSearch(AURL: string; AInFields, AInValues: array of string;
      AResultType: Integer; var AOutStrs: array of string;
      var AOutRecords: TOVArr): Integer;
  public
    function SystemDateTime: TDateTime;
    function Search(AURL: string; AInFields, AInValues: array of string; var AOutStrs: array of string): Integer; overload;
    function Search(AURL: string; AInFields, AInValues: array of string; var AOutRecords: TOVArr): Integer; overload;
    function Search(AURL: string; AInFields, AInValues: array of string; var AOutStrs: array of string ; var AOutRecords: TOVArr): Integer; overload;
    function Search(AURL: string; AInFields, AInValues: array of string; AResultType: Integer; var AOutStrs: array of string ; var AOutRecords: TOVArr): Integer; overload;
    // ALoginType, 登录类型，1 正常情况下的用户名密码；2 紫光平台调用仅用户名无密码
    function Login(AAccount, APW: string; ALoginType: Integer; var AInfo, ACheckCode: string): TLoginType;
    function ConnectServer(AIP: string; var ACompanyName: string): Integer;  // 新装软件，先弹出设置IP窗口
    function UpDataFile(AUserID, ATenderID, APhaseNo: Integer; AFile, AMD5_JL: string;
      AIsSubmit: Boolean; var AResultStr: string; ACheckPassed: Boolean; ACheckerMemo: string): Boolean;
    function UpAttachmentFile(AUperID, AWebID, ABillID: Integer; AFile,
      ACategory, AMemo, APhaseName: string; var ANewFileName: string): Boolean;
    function GetAttachmentFileList(AWebID: Integer; var vArr: TOVArr): Boolean;
    function zip(AFileArr: array of string): string;
    function CheckZip(AZipFile: string; AFileCount: Integer): Boolean;   // 检测zip是否能够正确解压出所有文件。
    function TempName(ALength: Integer = 12): string;
    function WebPath: string;
    function UserPath: string;
    // 下载文件：源文件网址；存储到本地的位置
    function DownFile(ASourceURL: string; var ALocalFile: string): Boolean;
    // 用于调试输出值，解决灵异现象(有些现象调试环境正常，运行环境时有时无)
    procedure Debug(AFileName, AStr: string); overload;
    procedure Debug(AFileName: string; AInFields, AInValues: array of string); overload;
    function NetError(AMid: string): string;
    function PageError(AMid: string): string;
    function ExistInServer(AWebID: Integer): Boolean;
    function GetNameFromURLProtocol(AURLProtocol: string): string;

    property Account: string read FAccount write SetAccount;
    property UserID: Integer read FUserID write SetUserID;
    property RealName: string read FRealName write SetRealName;
    property UserFlag: Integer read FUserFlag write FUserFlag;
    property Company: string read FCompany write FCompany;
    property Role: string read FRole write FRole;

    property MeasureURL: string read FMeasureURL;
    property WebSoftURL: string read FWebSoftURL;
    property PassportURL: string read FPassportURL;
    property LoginURL: string read FLoginURL;
    property WebLoginURL: string read FWebLoginURL;
    property LoginBannerURL: string read FLoginBannerURL;
    property LogoutURL: string read FLogoutURL;
    property RegURL: string read FRegURL;
    property PwdURL: string read FPwdURL;
    property CheckOnLineURL: string read FCheckOnLineURL;
    property ServerDateTimeURL: string read FServerDateTimeURL;
    property UserImageURL: string read FUserImageURL write FUserImageURL;
    property LoginCloudURL: string read FLoginCloudURL write FLoginCloudURL;
  end;


function PHPWeb: TPHPWeb;
// 全国  广东  标后预算 定额排版  港口水工  内河航运  疏浚 清单编制
function ExeCategoryName: string;

implementation

uses
  MD5Unit, IdMultipartFormData, VCLUnZip, VCLZip,
  IniFiles, Forms, UtilMethods, Variants, ConstUnit{, Controls, Windows};

var g_PHPWeb: TPHPWeb;

{$R *.dfm}

{ TPHPWeb }

function PHPWeb: TPHPWeb;
begin
  if g_PHPWeb = nil then
    g_PHPWeb := TPHPWeb.Create(nil);
  Result := g_PHPWeb;
end;

function ExeCategoryName: string;
begin
  Result := 'JLZF';
end;

function TPHPWeb.Login(AAccount, APW: string; ALoginType: Integer; var AInfo, ACheckCode: string): TLoginType;
var vArr: array of string;
begin
  vArr := VarArrayOf(['uid', 'name', 'email', 'ucompany', 'jobtitle', 'avatar', 'msg']);
  case Search(FMeasureURL + 'signin', ['v3name', 'v3pass', 'logintype'], [AnsiToUtf8(AAccount), APW, IntToStr(ALoginType)], vArr) of
    -1: Result := ltDisCon;
    0:
    begin
      AInfo := vArr[0];
      Result := ltLoginFail;
    end;
    1:
    begin
      FUserID := StrToInt(vArr[0]);
      FRealName := vArr[1];
      FAccount := AAccount;  // vArr[2]
      FCompany := vArr[3];
      FRole := vArr[4];
      FUserImageURL := vArr[5];
      AInfo := vArr[6];
      Result := ltCon;
    end;
  end;
end;

procedure TPHPWeb.SetUserID(const Value: Integer);
begin
  FUserID := Value;
end;

procedure TPHPWeb.SetAccount(const Value: string);
begin
  FAccount := Value;
end;

procedure TPHPWeb.DataModuleCreate(Sender: TObject);
var ini: TIniFile;
begin
  FServerDateTime := -1;

  ini := TIniFile.Create(ExtractFilePath(Application.ExeName) + 'Cloud.ini');
  try
//    FMeasureURL := ini.ReadString('URL', 'MeasureURL', '');
    FMeasureURL := 'http://' + ini.ReadString('URL', 'Server', '') +
      ini.ReadString('URL', 'MeasureURL', '');
    FWebSoftURL := ini.ReadString('URL', 'WebSoftURL', '');
    FPassportURL := ini.ReadString('URL', 'PassportURL', '');
    FLoginCloudURL := ini.ReadString('URL', 'LoginCloudURL', '');

    FLoginURL := FWebSoftURL + ini.ReadString('URL', 'LoginURL', '');
    FWebLoginURL := FWebSoftURL + ini.ReadString('URL', 'FWebLoginURL', '');
    FLoginBannerURL := FWebSoftURL + ini.ReadString('URL', 'LoginBannerURL', '');
    FLogoutURL := FWebSoftURL + ini.ReadString('URL', 'LogoutURL', '');
    FRegURL := FPassportURL + ini.ReadString('URL', 'RegURL', '');
    FPwdURL := FPassportURL + ini.ReadString('URL', 'PwdURL', '');
    FCheckOnLineURL := FWebSoftURL + ini.ReadString('URL', 'CheckOnLineURL', '');
    FServerDateTimeURL := FWebSoftURL + ini.ReadString('URL', 'ServerDateTimeURL', '');
  finally
    ini.Free;
  end;
end;

procedure TPHPWeb.SetRealName(const Value: string);
begin
  FRealName := Value;
end;

function TPHPWeb.zip(AFileArr: array of string): string;
var vZip: TVCLZip;
  sAppFile, sZipFile: string;
  i: Integer;
begin
  Result := 'Error';
  sAppFile := AFileArr[Low(AFileArr)];
  sZipFile := ExtractFilePath(sAppFile) + ExtractFileNameWithoutExt(sAppFile) + '.up';

  if FileExists(sZipFile) then
      DeleteFile(sZipFile);

  vZip := TVCLZip.Create(nil);
  try
    for i := Low(AFileArr) to High(AFileArr) do
    begin
      if FileExists(AFileArr[i]) then
        vZip.FilesList.Add(AFileArr[i]);
    end;

    vZip.ZipName := sZipFile;
    // PHP不支持解压加密zip文件
    //vZip.Password := 'jlzf.Sc.2014';
    vZip.Recurse := True;
    vZip.ZipComment := '纵横计量支付';
    vZip.OverwriteMode := Always;
    vZip.Zip;
    Result := sZipFile;

    for i := Low(AFileArr) to High(AFileArr) do
      DeleteFile(AFileArr[i]);
  finally
    vZip.Free;
  end;
end;

function TPHPWeb.CheckZip(AZipFile: string; AFileCount: Integer): Boolean;
var vUnZip: TVCLUnZip;
begin
  vUnZip := TVCLUnZip.Create(nil);
  try
    vUnZip.ZipName := AZipFile;
    vUnZip.DestDir := 'C:\Temp\MeasureTemp\';
    vUnZip.DoAll := True;
    vUnZip.RecreateDirs := True;
    vUnZip.RetainAttributes := True;
    vUnZip.OverwriteMode := Always;
    Result := (AFileCount = vUnZip.UnZip);
  finally
    DeleteFolder(vUnZip.DestDir);
    vUnZip.Free;
  end;
end;


function TPHPWeb.UpDataFile(AUserID, ATenderID, APhaseNo: Integer; AFile, AMD5_JL: string;
  AIsSubmit: Boolean; var AResultStr: string; ACheckPassed: Boolean; ACheckerMemo: string): Boolean;
var
  IdDataStream: TIdMultiPartFormDataStream;
  sResult, sURL: string;
  J: TCslJson;
  sZipMD5: string;
begin
  Result := False;

  if not FileExists(AFile) then Exit;

  IdDataStream := TIdMultiPartFormDataStream.Create;
  try
    if ACheckPassed then   // 审核通过
    begin
      if AIsSubmit then
      begin
        sURL := Format('%speriod/%d/%d/%d/creat', [FMeasureURL, AUserID, ATenderID, APhaseNo])
      end
      else
      begin
        sURL := FMeasureURL + 'user/audit/measure';
        IdDataStream.AddFormField('userid', IntToStr(AUserID));
        IdDataStream.AddFormField('tenderid', IntToStr(ATenderID));
        IdDataStream.AddFormField('phaseno', IntToStr(APhaseNo));
        IdDataStream.AddFormField('CheckerMemo', ReplaceCharsForJson(ACheckerMemo));
      end;
    end
    else  // 审核不通过
    begin
      sURL := Format('%suser/set/%d/%d/%d/checkno', [FMeasureURL, AUserID, ATenderID, APhaseNo]);
      IdDataStream.AddFormField('CheckerMemo', ReplaceCharsForJson(ACheckerMemo));
    end;

    IdDataStream.AddFile('upfile', AFile, 'text/plain');
    IdDataStream.AddFormField('upfile', AFile);
    IdDataStream.AddFormField('MD5_JL', AMD5_JL);
    sZipMD5 := MD5_File(AFile);
    IdDataStream.AddFormField('MD5_Zip', sZipMD5);

    IdDataStream.Position := 0;
    try
      sResult := IdHTTP.Post(sURL, IdDataStream);
    except
      Abort;
    end;
  finally
    IdDataStream.Free;
    DeleteFile(AFile);
  end;

  J := TCslJson.Create;
  try
    J.Text := Utf8ToAnsi(sResult);
    if SameText(J.Value['status'], 'true') then
      Result := True
    else
    begin
      Result := False;
      AResultStr := J.Value['msg'];
    end;
  finally
    J.Free;
  end;
end;

function TPHPWeb.Search(AURL: string; AInFields, AInValues: array of string; var AOutStrs: array of string): Integer;
var vA: TOVArr;
begin
  Result := CustomSearch(AURL, AInFields, AInValues, 0, AOutStrs, vA);
end;

function TPHPWeb.Search(AURL: string; AInFields, AInValues: array of string; var AOutRecords: TOVArr): Integer;
var vA: array of string;
begin
  Result := CustomSearch(AURL, AInFields, AInValues, 1, vA, AOutRecords);
end;

function TPHPWeb.Search(AURL: string; AInFields, AInValues: array of string; var AOutStrs: array of string; var AOutRecords: TOVArr): Integer;
begin
  Result := CustomSearch(AURL, AInFields, AInValues, 2, AOutStrs, AOutRecords);
end;

function TPHPWeb.Search(AURL: string; AInFields, AInValues: array of string; AResultType: Integer; var AOutStrs: array of string; var AOutRecords: TOVArr): Integer;
begin
  Result := CustomSearch(AURL, AInFields, AInValues, 3, AOutStrs, AOutRecords);
end;

function TPHPWeb.TempName(ALength: Integer): string;
const
  CodedBuf: array[0..35] of Char = ('0', '1', '2', '3', '4', '5',
  '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I',
  'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V',
  'W', 'X', 'Y', 'Z');
begin
  Result := '';
  Randomize;
  while Length(Result) < ALength do
    Result := Result + CodedBuf[Random(36)];
end;

function TPHPWeb.WebPath: string;
begin
  Result := ExtractFilePath(Application.ExeName) + 'Web\';
  if not DirectoryExists(Result) then
    ForceDirectories(Result);
end;

function TPHPWeb.UserPath: string;
begin
  Result := ExtractFilePath(Application.ExeName) + 'Web\Users\' + IntToStr(FUserID) + '\';
  if not DirectoryExists(Result) then
    ForceDirectories(Result);
end;

function TPHPWeb.DownFile(ASourceURL: string; var ALocalFile: string): Boolean;
var
  vStream: TMemoryStream;
  iFlag: Integer;
  bOK: Boolean;

  procedure SafeDownFile(ASourceURL: string; var ALocalFile: string);
  begin
    Inc(iFlag);
    bOK := False;
    try
      IdHTTP.Get(ASourceURL, vStream);
      vStream.SaveToFile(ALocalFile);
      bOK := True;
    except
      bOK := False;
    end;
  end;
begin
  iFlag := 0;
  bOK := False;
  Result := False;

  if Trim(ASourceURL) = '' then Exit;
  if Trim(ALocalFile) = '' then Exit;

  if (ExtractFileExt(ALocalFile) = '.rmf') and FileExists(ALocalFile) then
    DeleteFile(ALocalFile);

  vStream := TMemoryStream.Create;
  try
    while (not bOK) and (iFlag < 3) do   // 尝试3次
      SafeDownFile(ASourceURL, ALocalFile);

    Result := bOK;
  finally
    vStream.Free;
  end;
end;

function TPHPWeb.CustomSearch(AURL: string; AInFields,
  AInValues: array of string; AResultType: Integer;
  var AOutStrs: array of string; var AOutRecords: TOVArr): Integer;
var
  i: Integer;
  postList: TStrings;
  ssResponse: TStringStream;
  bDone: Boolean;
  vJson: TCslJson;
begin
  Result := -1;
  postList := TStringList.Create;
  ssResponse := TStringStream.Create('');
  try
    try
      for i := Low(AInFields) to High(AInFields) do
        postList.Add(Format('%s=%s', [AInFields[i], AInValues[i]]));

      IdHTTP.Post(AURL, postList, ssResponse);
      bDone := True;
    except
      bDone := False;
    end;

    if (bDone) and (Pos('200 OK', IdHTTP.ResponseText) <> 0) then   // 网络已通
    begin
      vJson := TCslJson.Create;
      try
        vJson.Text := Utf8ToAnsi(ssResponse.DataString);

        if SameText(vJson.Value['status'], 'true') then          // 数据读取成功
        begin
          case AResultType of
            0:
            begin
              for i := Low(AOutStrs) to High(AOutStrs) do
                AOutStrs[i] := vJson.Value[AOutStrs[i]];
            end;
            1:
            begin
              AOutRecords := vJson.ArrayValues('info');
            end;
            2:
            begin
              for i := Low(AOutStrs) to High(AOutStrs) do
                AOutStrs[i] := vJson.Value[AOutStrs[i]];

              AOutRecords := vJson.ArrayValues('info');
            end;
            3:
            begin
              vJson.ChildValues('info', AOutStrs);
              AOutRecords := vJson.ArrayValues('auditinfo');
            end;
          end;
          Result := 1;
        end
        else                                                     // 数据读取失败
        begin
          case AResultType of
            0:
            begin
              AOutStrs[Low(AOutStrs)] := vJson.Value['msg'];
            end;
            1:
            begin
              SetLength(AOutRecords, 1, 1);
              AOutRecords[0, 0] := vJson.Value['msg'];
            end;
            2, 3:
            begin
              AOutStrs[Low(AOutStrs)] := vJson.Value['msg'];

              SetLength(AOutRecords, 1, 1);
              AOutRecords[0, 0] := vJson.Value['msg'];
            end;
          end;
          Result := 0;
        end;
      finally
        vJson.Free;
      end;
    end;
  finally
    postList.Free;
    ssResponse.Free;
  end;
end;

function TPHPWeb.SystemDateTime: TDateTime;
begin
  Result := Now;
end;

function TPHPWeb.NetError(AMid: string): string;
begin
  Result := Format('当前网络状态较差(-1)，%s，请重新尝试或重新登录后再尝试！', [AMid]);
end;

function TPHPWeb.PageError(AMid: string): string;
begin
  Result := Format('Web页返回错误(000J)，%s，请重新尝试或联系纵横客服。', [AMid]);
end;

procedure TPHPWeb.Debug(AFileName, AStr: string);
var vSL: TStringList;
  sAdd: string;
begin
  vSL := TStringList.Create;
  try
    sAdd := Format('%s%d %s %s', [#10#13#10#13#10#13#10#13#10#13,
      UserID, RealName, Account]);

    vSL.Add(AStr + sAdd);

    if Pos('Debug_', AFileName) = 0 then
      AFileName := 'Debug_' + AFileName;

    vSL.SaveToFile(WebPath + AFileName + '.txt');
  finally
    vSL.Free;
  end;
end;

procedure TPHPWeb.Debug(AFileName: string; AInFields, AInValues: array of string);
var vSL: TStringList;
  sAdd: string;
  i: Integer;
begin
  if G_IsTest then
  begin
    vSL := TStringList.Create;
    try
      sAdd := Format('%s%d  %s  %s', [#10#13#10#13#10#13#10#13#10#13, UserID, RealName, Account]);

      for i := Low(AInFields) to High(AInFields) do
        vSL.Add(AInFields[i] + #9#9 + AInValues[i]);

      vSL.Add(sAdd);

      if Pos('Debug_', AFileName) = 0 then
        AFileName := 'Debug_' + AFileName;

      vSL.SaveToFile(WebPath + AFileName + '.txt');
    finally
      vSL.Free;
    end;
  end;
end;

function TPHPWeb.ConnectServer(AIP: string; var ACompanyName: string): Integer;
var vArr: array of string;
  sURL: string;
begin
  sURL := Format('http://%s/api/client/software/title', [AIP]);
  vArr := VarArrayOf(['msg']);
  Result := Search(sURL, [], [], vArr);
  case Result of
    -1: ACompanyName := '地址不存在';
    0: ACompanyName := '服务器Web页错误';
    1: ACompanyName := vArr[0];
  end;
end;

function TPHPWeb.UpAttachmentFile(AUperID, AWebID, ABillID: Integer; AFile,
  ACategory, AMemo, APhaseName: string; var ANewFileName: string): Boolean;
var
  vMPFDS: TIdMultiPartFormDataStream;
  sResult, sURL: string;
  J: TCslJson;
  vArr: array of string;
begin
  Result := False;

  if not FileExists(AFile) then
  begin
//    Application.MessageBox(PChar(AFile + ' 文件不存在！'), '错误', MB_OK + MB_ICONERROR);
    Exit;
  end;

  vMPFDS := TIdMultiPartFormDataStream.Create;
  try
    sURL := Format('%stender/attachment/%d/%d/upload', [FMeasureURL, AWebID, AUperID]);
    vMPFDS.AddFile('upitem', AFile, 'text/plain');
    vMPFDS.AddFormField('itemid', IntToStr(ABillID));
    vMPFDS.AddFormField('Category', ACategory);
    vMPFDS.AddFormField('Memo', ReplaceCharsForJson(AMemo));
    vMPFDS.AddFormField('PhaseName', APhaseName);

    vMPFDS.Position := 0;
    try
      sResult := IdHTTP.Post(sURL, vMPFDS);
    except
      Abort;
    end;
  finally
    vMPFDS.Free;
  end;

  J := TCslJson.Create;
  try
    J.Text := Utf8ToAnsi(sResult);
    if SameText(J.Value['status'], 'true') then
    begin
      Result := True;
      vArr := VarArrayOf(['onlinefilename']);
      J.ChildValues('iteminfo', vArr);
      ANewFileName := vArr[0];
    end
    else
    begin
      Result := False;
    end;
  finally
    J.Free;
  end;
end;

function TPHPWeb.GetAttachmentFileList(AWebID: Integer; var vArr: TOVArr): Boolean;
var sURL: string;
begin
  sURL := Format('%stender/attachment/%d/list', [FMeasureURL, AWebID]);
  Result := Search(sURL, [], [], vArr) = 1;
end;

function TPHPWeb.ExistInServer(AWebID: Integer): Boolean;
var vArr: array of string;
  iResult: Integer;
  sSearchURL: string;
begin
  sSearchURL := Format('%stender/get/%d/exist', [PHPWeb.MeasureURL, AWebID]);
  vArr := VarArrayOf(['id', 'name']);
  iResult := PHPWeb.Search(sSearchURL, [''], [''], vArr);

  if (iResult = 1) and (High(vArr) >= 0) then
    Result := True
  else
    Result := False;
end;

// 格式为 Measure:chen
function TPHPWeb.GetNameFromURLProtocol(AURLProtocol: string): string;
begin
  if Trim(AURLProtocol) = '' then
    Result := ''
  else
    Result := Copy(AURLProtocol, 9, Length(AURLProtocol) - 8);
end;

initialization

finalization
  if g_PHPWeb <> nil then
    g_PHPWeb.Free;

end.