Delphi 系统服务 Http服务 YxdIOCP TService

说明:  编写一个系统http服务， 供多个终端请求， 并返回相应数据.

         程序划分为服务、服务安装程序、终端。

控件: 使用了YxdIOCP， 下载地址为(感谢作者的分享): https://github.com/yangyxd/YxdIOCP

以下对服务、服务安装程序、终端、测试进行单独说明:

服务:

 

File-> new-> othor-> ServiceApplication

工程文件保存为ControlCenter, Unit1.pas保存为uService.pas.

新建配置文件Server.ini， 添加如下

[SYSTEM]
iHttpPort=5000

 

1.  工程文件ControlCenter内容如下

    需要注意的是，在uses单元引入了Forms单元，方便调试使用(SvcMgr和Forms下都有Application类，在代码底部可看到区别)。

    Release模式下，不会创建窗体。 Debug模式下会创建窗体，方便调试。

program ControlCenter;

uses
  SvcMgr,
  Forms,
  uService in 'uService.pas' {CenterService: TService},
  uPublic in 'public\uPublic.pas',
  uHttpEvent in 'public\uHttpEvent.pas',
  uServer in 'public\uServer.pas',
  uVar in 'public\uVar.pas',
  uFrmMain in 'form\uFrmMain.pas' {frmMain},
  uAppFactory in 'public\uAppFactory.pas';

{$R *.RES}

var
  sErr: string;

begin
  // Windows 2003 Server requires StartServiceCtrlDispatcher to be
  // called before CoRegisterClassObject, which can be called indirectly
  // by Application.Initialize. TServiceApplication.DelayInitialize allows
  // Application.Initialize to be called from TService.Main (after
  // StartServiceCtrlDispatcher has been called).
  //
  // Delayed initialization of the Application object may affect
  // events which then occur prior to initialization, such as
  // TService.OnCreate. It is only recommended if the ServiceApplication
  // registers a class object with OLE and is intended for use with
  // Windows 2003 Server.
  //
  // Application.DelayInitialize := True;
  //
  {$IFNDEF DEBUG}
    {Release版本}
    SvcMgr.Application.Initialize;
    SvcMgr.Application.CreateForm(TCenterService, CenterService);
    SvcMgr.Application.Run;
  {$ELSE}
    {Debug版本}
    Forms.Application.Initialize;
    AppFactory:= TAppFactory.Create;
    if AppFactory.Factory(sErr) then
      Forms.Application.CreateForm(TfrmMain, frmMain);
    Forms.Application.Run;
//    AppFactory.Destroy;
  {$ENDIF}
end.

2. uService.pas内容如下:

    在ServiceStart方法里完成服务的启动，在factory方法里

   

unit uService;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, SvcMgr, Dialogs,
  uAppFactory;

type
  TCenterService = class(TService)
    procedure ServiceStart(Sender: TService; var Started: Boolean);
    procedure ServiceStop(Sender: TService; var Stopped: Boolean);
    procedure ServiceExecute(Sender: TService);
  private
    { Private declarations }
  public
    function GetServiceController: TServiceController; override;
    { Public declarations }
  end;

var
  CenterService: TCenterService;
  AppFactory: TAppFactory;

implementation

uses uPublic, uFrmMain, uVar;

{$R *.DFM}

procedure ServiceController(CtrlCode: DWord); stdcall;
begin
  CenterService.Controller(CtrlCode);
end;

function TCenterService.GetServiceController: TServiceController;
begin
  Result := ServiceController;
end;

procedure TCenterService.ServiceExecute(Sender: TService);
begin
  while not Terminated do
  begin
    systemLog('ServiceExecute');
    Sleep(5000);
  end;
end;

procedure TCenterService.ServiceStart(Sender: TService; var Started: Boolean);
var
  sErr: string;
begin
  AppFactory:= TAppFactory.Create;
  AppFactory.Factory(sErr);
  Started:= True;
  systemLog('ServiceStart');
end;

procedure TCenterService.ServiceStop(Sender: TService; var Stopped: Boolean);
begin
  if Assigned(AppFactory) then
    FreeAndNil(AppFactory);
  Stopped:= True;
  systemLog('ServiceStop');
end;

end.

3. uPublic.pas内容如下

unit uPublic;

interface

uses Windows, SysUtils, iocp.Http, superobject;

procedure ProcessMessage;
//写日志
procedure systemLog(Msg: string);

function getParam(Request: TIocpHttpRequest; sParam :string):string;

implementation

//1.3.7.0   防止切换输入法等引起程序假死
procedure ProcessMessage;
var
  Msg: TMsg;
begin
  if PeekMessage(Msg, 0, 0, 0, PM_REMOVE) then
  begin
    TranslateMessage(Msg);
    DispatchMessage(Msg);
  end;
end;

procedure systemLog(Msg: string);
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;

function getParam(Request: TIocpHttpRequest; sParam :string):string;
var
 js :ISuperObject;
begin
  Result := '';
  if Request.ContentType = 'application/json' then
  begin
    js := SO(UTF8Decode(Request.DataString));
    if js <> nil then
    if js[sParam] <> nil then
    Result := js[sParam].AsString;
  end
  else
  begin
    Result := Request.GetParam(sParam);
  end;
end;

end.

4. uHttpEvent.pas内容如下

    定义事件处理类，包含了心跳， 获取服务时间， 数据返回。 方便测试使用。

unit uHttpEvent;

interface

uses
  iocp, iocp.Http, superobject, SysUtils;

type
  THttpEvent= class
    //心跳
    class function _Heart(request: TIocpHttpRequest; response: TIocpHttpResponse): Boolean;
    //获取服务时间
    class function _GetServerTime(request: TIocpHttpRequest; response: TIocpHttpResponse): Boolean;
    //返回数据
    class function _HttpSend(response: TIocpHttpResponse; sSend: string): Boolean;
  end;

implementation

uses uPublic;

{ THttpEvent }

class function THttpEvent._GetServerTime(request: TIocpHttpRequest;
  response: TIocpHttpResponse): Boolean;
var
  sMethod, sCode, sMsg, sAppkey, sSend: string;
  vJs, tJs: ISuperObject;
begin
  sCode:= '9001';
  sMsg:= 'Unknown error';
  sMethod:= 'servertime';
  try
    sAppkey:= GetParam(request, 'appKey');
    sCode:= '9000';
    sMsg:= 'Success';
  finally
    tJs:= TSuperObject.Create;
    tJs.S['code']:= sCode;
    tJs.S['message']:= sMsg;
    tJs.S['sMethod']:= sMethod;
    tJs.S['servertime']:= FormatDateTime('YYYY-MM-DD hh:mm:ss', Now);
    sSend:= tJs.AsString;
    _HttpSend(response, sSend);
  end;
end;

class function THttpEvent._Heart(request: TIocpHttpRequest;
  response: TIocpHttpResponse): Boolean;
var
  sMethod, sCode, sMsg, sContent, sSend: string;
  vJs, tJs: ISuperObject;
begin
  sCode:= '9001';
  sMsg:= 'Unknown error';
  sMethod:= 'heart';
  systemLog(request.DataString);
  try
    sContent:= GetParam(request, 'content');
    systemLog(sContent);
    sCode:= '9000';
    sMsg:= 'Success';
  finally
    tJs:= TSuperObject.Create;
    tJs.S['code']:= sCode;
    tJs.S['message']:= sMsg;
    tJs.S['method']:= sMethod;
    tJs.S['servertime']:= FormatDateTime('YYYY-MM-DD hh:mm:ss', Now);
    sSend:= tJs.AsString;
    _HttpSend(response, sSend);
  end;
end;

class function THttpEvent._HttpSend(response: TIocpHttpResponse;
  sSend: string): Boolean;
var
  O: TIocpHttpWriter;
begin
  O:= response.GetOutWriter();
  O.Charset:= hct_UTF8;
  O.Write(sSend);
  O.Flush;
end;

end.

5. uServer.pas内容如下

    服务的核心类，处理http请求的响应。

unit uServer;

interface

uses
  iocp, iocp.Http, iocp.Utils.Hash, SysUtils, Classes, iocp.Http.WebSocket;

type
  PMethod = ^TMethod;

  TOnProcRequest= function(Request: TIocpHttpRequest; Response: TIocpHttpResponse): Boolean of object;
  TOnRecvBuffer= procedure(const pvClientContext: TIocpContext; buf: Pointer; len: Cardinal; errCode: integer) of object;
  TOnAccept= procedure(pvSocket: THandle; const pvAddr: string; pvPort: Word; var vAllowAccept: Boolean) of object;
  TOnDisAccept= procedure(const Context: TIocpContext) of object;

  TCenterServer= class(TObject)
  private
    FWebService: TIocpHttpServer;
    FProcList: TStringHash;
  protected
    function isDestroying: Boolean;
    procedure doRequest(Sender: TIocpHttpServer; request: TIocpHttpRequest; response: TIocpHttpResponse);
    procedure doWebSocketRequest(Sender: TIocpWebSocketServer; request: TIocpWebSocketRequest; response: TIocpWebSocketResponse);
    procedure doFreeProcItem(item: PHashItem);
  public
    FStickRef: Integer;
    constructor Create(httpPort: Word); reintroduce;
    destructor Destroy; override;
    procedure RegHttpProc(const URI: string; const Proc: TOnProcRequest);
    procedure RegSocketProc(const OnRecvBuffer: TOnRecvBuffer; const onAccept: TOnAccept; const onDisAccept: TOnDisAccept);
    procedure Start;
    procedure Stop;
  end;

var
  GURL: string;

implementation

uses uPublic;

{ TCenterServer }

constructor TCenterServer.Create(httpPort: Word);
begin
  FWebService:= TIocpHttpServer.Create(nil);
  FWebService.ListenPort:= httpPort;
  FWebService.UploadMaxDataSize:= 1024* 1024;
  FWebService.MaxTaskWorker:= 64;
  FWebService.MaxContextPoolSize:= 1;
  FWebService.OnHttpRequest:= doRequest;

  FProcList:= TStringHash.Create();
  FProcList.OnFreeItem:= doFreeProcItem;
end;

destructor TCenterServer.Destroy;
begin
  try
    Stop;
    if Assigned(FWebService) then
      FreeAndNil(FWebService);
    if Assigned(FProcList) then
      FreeAndNil(FProcList);
  except

  end;
  inherited;
end;

procedure TCenterServer.doFreeProcItem(item: PHashItem);
begin
  if item<> nil then
    Dispose(Pointer(item.Value));
end;

procedure TCenterServer.doRequest(Sender: TIocpHttpServer;
  request: TIocpHttpRequest; response: TIocpHttpResponse);
var
  sMethod: string;
  index: Number;
begin
  if request.URI<> GURL then
  begin
    response.ErrorRequest(404);
    Exit;
  end;
  sMethod:= getParam(request, 'method');
  index:= FProcList.ValueOf(LowerCase(string(sMethod)));
  if index<> -1 then
  begin
    TOnProcRequest(PMethod(Pointer(index))^)(request, response);
  end
  else
  begin
    response.ErrorRequest(404);
  end;
end;

procedure TCenterServer.doWebSocketRequest(Sender: TIocpWebSocketServer;
  request: TIocpWebSocketRequest; response: TIocpWebSocketResponse);
var
  S: TMemoryStream;
  Data: string;
begin
  S:= TMemoryStream.Create;
  try
    Data:= request.DataString(hct_UTF8);
    S.Write(Data[1], Length(Data) {$IFDEF UNICODE} sh1 1 {$ENDIF});
    S.Position:= 0;
    response.Send(S, wso_Text);
  finally
    S.Free;
  end;
  response.Send(request.DataString());
end;

function TCenterServer.isDestroying: Boolean;
begin
  Result:= (not Assigned(Self));
end;

procedure TCenterServer.RegHttpProc(const URI: string;
  const Proc: TOnProcRequest);
var
  P: PMethod;
begin
  if Length(URI)= 0 then
    Exit;
  if Assigned(Proc) then
  begin
    New(P);
    P^:= TMethod(Proc);
    FProcList.Add(LowerCase(URI), Integer(P));
  end;
end;

procedure TCenterServer.RegSocketProc(const OnRecvBuffer: TOnRecvBuffer;
  const onAccept: TOnAccept; const onDisAccept: TOnDisAccept);
begin
  //
end;

procedure TCenterServer.Start;
begin
  FWebService.Open;
end;

procedure TCenterServer.Stop;
begin
  FWebService.Close;
end;

end.

6. uVar.pas内容如下

unit uVar;

interface

uses
  SysUtils, Forms, IniFiles;

type
  TAppParam= class
  public
    class function AppPath: string;   // 路径
    class function AppName: string;   // 程序名
    class function AppVer: string;    // 版本
  end;

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

  //运行参数
  TRunParam = record
    iHttpPort  : Integer;
  end;

  TAppRunClass = class
  private
    FRunParam : TRunParam;                       //运行参数 从ini文件或数据库中读取
  public
    constructor Create;
    destructor Destroy; override;
    //读取基础数据
    function ReadPara : Boolean;               //读取基础参数
  published
    property RunPara : TRunParam read FRunParam write FRunParam ;
  end;

var
  GAppRunClass: TAppRunClass;

implementation

{ TAppParam }

class function TAppParam.AppName: string;
begin
  Result := ExtractFileName(Application.ExeName);
end;

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

class function TAppParam.AppVer: string;
begin
  //
end;

{ TFilePath }

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

{ TAppRunClass }

constructor TAppRunClass.Create;
begin
  //
end;

destructor TAppRunClass.Destroy;
begin

  inherited;
end;

function TAppRunClass.ReadPara: Boolean;
var
  sFile : string;
  sIni : TIniFile;
begin
  Result := False;
  sFile := TFilePath.IniFile;
  if FileExists(sFile) then
  begin
    sIni := TIniFile.Create(sFile);
    try
      FRunParam.iHttpPort     := sIni.ReadInteger('SYSTEM', 'iHttpPort', 5000);
      Result := True;
    finally
      FreeAndNil(sIni);
    end;
  end;
end;

end.

7. uFrmMain.pas窗体如下

    窗体的create里写了服务的启动，供调试使用。(Release下是不会创建该窗体的)

unit uFrmMain;

interface

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

type
  TfrmMain = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
    FServer: TCenterServer;
  public
    //
  end;

var
  frmMain: TfrmMain;

implementation

uses uHttpEvent, uPublic, uVar;

{$R *.dfm}

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  FServer:= TCenterServer.Create(GAppRunClass.RunPara.iHttpPort);
  FServer.RegHttpProc('cwx.heart', THttpEvent._Heart);
  FServer.RegHttpProc('cwx.servertime', THttpEvent._GetServerTime);
  GURL:= '/gateway.do';
  FServer.Start;
  SystemLog('FServer.Started');
end;

procedure TfrmMain.FormDestroy(Sender: TObject);
begin
  if Assigned(FServer) then
    FreeAndNil(FServer);
end;

end.

8. uAppFactory.pas内容如下

unit uAppFactory;

interface

uses
  SysUtils, Forms, Windows, DateUtils, uServer;

type
  TAppFactory= class
  private
    FServer: TCenterServer;
  protected
    function CreateMainForm(var sErr: string): Boolean; virtual;
  public
    constructor Create; virtual;
    destructor Destroy; override;
    function StartServer: Boolean;
    procedure StopServer;
    function Factory(var sErr: string): Boolean; virtual;
  end;

implementation

uses uVar, uFrmMain, uPublic, uHttpEvent;

{ TAppFactory }

constructor TAppFactory.Create;
var
  sPath: string;
  dDateTime: TDateTime;
begin
  GAppRunClass:= TAppRunClass.Create;
end;

function TAppFactory.CreateMainForm(var sErr: string): Boolean;
begin
  Result:= False;
  try
    if not Assigned(frmMain) then
      Application.CreateForm(TfrmMain, frmMain);
    Result:= True;
  except
    on e: Exception do
    begin
      sErr:= 'Err:创建主窗体失败 '+ e.message;
    end;
  end;
end;

destructor TAppFactory.Destroy;
begin
  StopServer;
  if Assigned(frmMain) then
    frmMain.Destroy;
  if Assigned(GAppRunClass) then
    FreeAndNil(GAppRunClass);
  inherited;
end;

function TAppFactory.Factory(var sErr: string): Boolean;
begin
  Result:= False;
  while not Result do
  begin
    ProcessMessage;
    if not GAppRunClass.ReadPara then
    begin
      sErr:= '系统参数读取错误, 系统无法正常启动!';
      systemLog(sErr);
      Sleep(5000);
      Continue;
    end;
    {$IFDEF RELEASE}
    if not StartServer then
    begin
      sErr:= '系统参数读取错误, 系统无法正常启动!';
      systemLog(sErr);
      Sleep(5000);
      Continue;
    end;
    {$ENDIF}
    Result:= True;
  end;
end;

function TAppFactory.StartServer: Boolean;
begin
  Result:= False;
  if Assigned(FServer) then
  begin
    Result:= True;
    Exit;
  end;
  //注册方法
  FServer:= TCenterServer.Create(GAppRunClass.RunPara.iHttpPort);
  FServer.RegHttpProc('cwx.heart', THttpEvent._Heart);
  FServer.RegHttpProc('cwx.servertime', THttpEvent._GetServerTime);
  GURL:= '/gateway.do';
  FServer.Start;
  SystemLog('FServer.Started');
  result:= True;
end;

procedure TAppFactory.StopServer;
begin
  if Assigned(FServer) then
    FreeAndNil(FServer);
end;

end.

服务安装:

 

可以通过cmd命令来进行安装，也可以写程序进行安装。

新建工程， 工程文件保存为InstallService, Unit1.pas保存为uFrmMain.pas.

 

1. 工程文件InstallService内容如下

program InstallService;

uses
  Forms,
  uFrmMain in 'uFrmMain.pas' {FrmMain};

{$R *.res}

begin
  Application.Initialize;
  Application.MainFormOnTaskbar := True;
  Application.CreateForm(TFrmMain, FrmMain);
  Application.Run;
end.

2. uFrmMain.pas内容如下

    注意以下InstallService方法的第一个参数和服务uService那里的Name属性要一致。

unit uFrmMain;

interface

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

type
  TFrmMain = class(TForm)
    memo1: TMemo;
    btn1: TButton;
    btn2: TButton;
    procedure btn1Click(Sender: TObject);
    procedure btn2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
     function InstallService(ServiceName, DisplayName, FileName: string): boolean;
     function UninstallService(ServiceName: string):boolean;
     function UpdateDes(name,des :string):Boolean;
  end;
var
  FrmMain: TFrmMain;

implementation
    uses ShellAPI;
{$R *.dfm}

{ TForm21 }

procedure TFrmMain.btn1Click(Sender: TObject);
begin
  memo1.Clear;
  if UninstallService('CenterService') then
    memo1.Lines.Add('服务卸载成功')
  else
    memo1.Lines.Add('服务卸载失败');
  Memo1.Lines.Add('如果卸载服务时有返回-1，则多试几次，或强制结束进程再卸载。');
end;

procedure TFrmMain.btn2Click(Sender: TObject);
var
 fnamePath,ServiceName :string;
begin
  memo1.Clear;
  SetCurrentDir(ExtractFilePath(Forms.Application.exename));
  SetCurrentDir(GetCurrentDir);
  fnamePath :=  GetCurrentDir +'\ControlCenter.exe';
  if not FileExists(fnamePath) then
  begin
    memo1.Lines.Add('error: ControlCenter.exe');
    Exit;
  end;
  if InstallService('CenterService','CWX服务',fnamePath) then
  begin
    memo1.Lines.Add('服务安装成功');
    UpdateDes('CenterService','CWX服务');
  end
  else
    memo1.Lines.Add('服务安装失败');
end;

function TFrmMain.InstallService(ServiceName, DisplayName,
  FileName: string): boolean;
var
  SCManager,Service: THandle;
  Args: pchar;
  str :string;
begin
  Result := False;
  SCManager := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
  if SCManager = 0 then Exit;
  try
   Service := CreateService(SCManager,  //句柄
                    PChar(ServiceName), //服务名称
                    PChar(DisplayName), //显示服务名
                    SERVICE_ALL_ACCESS, //服务访问类型
                    SERVICE_WIN32_OWN_PROCESS or SERVICE_INTERACTIVE_PROCESS, //服务类型  or SERVICE_WIN32_OWN_PROCESS,//
                    SERVICE_AUTO_START, //自动启动服务
                    SERVICE_ERROR_IGNORE, //忽略错误
                    PChar(FileName),  //启动的文件名
                    nil,  //name of load ordering group (载入组名) 'LocalSystem'
                    nil,  //标签标识符
                    nil,  //相关性数组名
                    nil,  //帐户(当前)
                    nil); //密码(当前)

    Args := nil;
    if Service = 0 then exit;
    if StartService(Service, 0, Args) then
      memo1.Lines.Add(DisplayName+' 服务已经启动')
    else
      memo1.Lines.Add(DisplayName+' 服务启动失败！');
    CloseServiceHandle(Service);
    CloseServiceHandle(SCManager);
  except on E: Exception do
    begin
      CloseServiceHandle(SCManager);
      Memo1.Lines.Add('失败原因是：' + E.Message);
    end;
  end;
  Result := True;
end;

function TFrmMain.UninstallService(ServiceName: string): boolean;
var
  SCManager,Service: THandle;
  ServiceStatus: SERVICE_STATUS;
  ss: LongBool;
begin
  Result:=false;
  SCManager := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);//获得SC管理器句柄
  if SCManager = 0 then Exit;
  try
    Service := OpenService(SCManager, PChar(ServiceName), SERVICE_ALL_ACCESS);

    //以最高权限打开指定服务名的服务,并返回句柄
    ss := ControlService(Service, SERVICE_CONTROL_STOP, ServiceStatus);
    Memo1.Lines.Add('停止服务结果：' + BoolToStr(ss));

    //向服务器发送控制命令,停止工作, ServiceStatus 保存服务的状态
    ss := DeleteService(Service);
    Memo1.Lines.Add('卸载服务结果：' + BoolToStr(ss));
    //从SC ManGer 中删除服务
    CloseServiceHandle(Service);
    result:=true;
    //关闭句柄,释放资源
  finally
    CloseServiceHandle(SCManager);
  end;
end;

function TFrmMain.UpdateDes(name, des: string): Boolean;
var
  reg: TRegistry;
begin 
  reg := TRegistry.Create; 
  try
    with reg do begin 
      RootKey := HKEY_LOCAL_MACHINE; 
      if OpenKey('SYSTEM\CurrentControlSet\Services\'+Name,false) then
      begin 
        WriteString('Description',des); 
      end; 
      CloseKey; 
    end; 
  finally 
    reg.Free; 
  end; 
end;

end.

终端:

 

在服务安装成功的情况下，通过终端可以向服务发出请求。

新建工程， 工程文件保存为ClientDemo, Unit1.pas保存为uFrmMain.pas.

新建配置文件Client.ini， 添加如下

[SYSTEM]
url=http://服务IP地址:服务开放端口/gateway.do

 

1. 工程文件ClientDemo内容如下

program ClientDemo;

uses
  Forms,
  uFrmMain in 'uFrmMain.pas' {Form21},
  uVar in 'uVar.pas';

{$R *.res}

begin
  Application.Initialize;
  Application.MainFormOnTaskbar := True;
  Application.CreateForm(TForm21, Form21);
  Application.Run;
end.

2. uFrmMain.pas内容如下

   

unit uFrmMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Mask, RzEdit, RzLabel, ExtCtrls,ActnList,uVar;

type
  TForm21 = class(TForm)
    btnHeart: TButton;
    btnServerTime: TButton;
    Memo1: TMemo;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure btnHeartClick(Sender: TObject);
    procedure btnServerTimeClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form21: TForm21;

implementation

uses superobject;

{$R *.dfm}

procedure TForm21.btnHeartClick(Sender: TObject);
var
  Vjson: ISuperObject;
  sOut: string;
begin
  Vjson := SO();
  try
    Vjson.S['poscode'] := '35';
    if not GAppRunClass.Info_POSt(sOut, 'cwx.heart', Vjson.AsString) then
    begin
      Memo1.Lines.Add(sOut);
      Exit;
    end;
    try
      Memo1.Lines.Add(sOut);
    except

    end;
  finally
    Vjson := nil;
  end;
end;

procedure TForm21.btnServerTimeClick(Sender: TObject);
var
  Vjson: ISuperObject;
  sOut: string;
begin
  Vjson := SO();
  try
    Vjson.S['poscode'] := '35';
    if not GAppRunClass.Info_POSt(sOut, 'cwx.servertime', Vjson.AsString) then
    begin
      Memo1.Lines.Add(sOut);
      Exit;
    end;
    try
      Memo1.Lines.Add(sOut);
    except

    end;
  finally
    Vjson := nil;
  end;
end;

procedure TForm21.FormCreate(Sender: TObject);
begin
  GAppRunClass := TAppRunClass.Create;
  GAppRunClass.ReadPara;
end;

procedure TForm21.FormDestroy(Sender: TObject);
begin
  if Assigned(GAppRunClass) then
    FreeAndNil(GAppRunClass);
end;

end.

3. uVar.pas内容如下

unit uVar;

interface

uses
  SysUtils,IniFiles,Forms,IdHTTP,superobject,CnSHA1,Classes;

type
  TRunPara = record
    url :string;
  end;

  TAppRunClass = class
  private
    FRunPara : TRunPara;
  published
    property RunPara : TRunPara read FRunPara write FRunPara ;
  public
    function ReadPara : Boolean;
    function Info_POSt(var sOut: string; smethod, content: string): Boolean;
    constructor Create;
    destructor Destroy; override;
  end;

var
  GAppRunClass : TAppRunClass;

implementation

{ TAppRunClass }

constructor TAppRunClass.Create;
begin

end;

destructor TAppRunClass.Destroy;
begin

  inherited;
end;


  
function TAppRunClass.Info_POSt(var sOut: string; smethod, content: string): Boolean;
var
  sSend, str: string;
  lSend: TStringList;
  fidhttp: Tidhttp;
begin
  fidhttp := Tidhttp.Create(nil);
  try
    fidhttp.Request.ContentType := 'application/x-www-form-urlencoded';
    fidhttp.ReadTimeout := 5000;
    fidhttp.ConnectTimeout := 5000;

    Result := False;
    lSend := TStringList.Create;
    try
      str := 'method=' + smethod;
      lSend.Add(UTF8Encode(str));
      str := 'charset=' + 'utf-8';
      lSend.Add(UTF8Encode(str));
      str := 'timestamp=' + FormatDateTime('yyyy-MM-dd HH:mm:ss', Now);
      lSend.Add(UTF8Encode(str));
      str := 'content=' + content;
      lSend.Add(UTF8Encode(str));
      try
        sOut := fidhttp.Post(GAppRunClass.RunPara.url, lSend);
        sOut := UTF8Decode(sOut);
        Result := True;
      except
        on e: Exception do
        begin
          sOut:= e.Message;
        end;
      end;
    finally
      FreeAndNil(lSend);
    end;
  finally
    FreeAndNil(fidhttp);
  end;
end;

function TAppRunClass.ReadPara: Boolean;
var
  sFile : string;
  sIni : TIniFile;
begin
  Result := False;
  sFile :=   ExtractFilePath(Application.ExeName) + 'Client.ini';
  if FileExists(sFile) then
  begin
    sIni := TIniFile.Create(sFile);
    try
      FRunPara.url := sIni.ReadString('SYSTEM','url','');
      Result := True;
    finally
      FreeAndNil(sIni);
    end;
  end;
end;

end.

测试:

 

1. 编译服务 Release版本, 编译服务安装程序 , 编译终端程序

    将三个程序和Server.ini、Client.ini都放在一个目录下。如下图所示

2. 安装服务端，右击InstallService.exe， 以管理员身份运行, 点击安装服务:

    控制面板-> 管理工具-> 服务

    cmd命令下输入regedit, 在HKEY_LOCAL_MACHINE-> SYSTEM-> CurrentControlSet-> Services下可以找到

3. 终端调用

    运行多个ClientDemo.exe， 进行调用

 

 

结束!