proxy server gatekeeper socket server agent VisiBroker
利用 ScktSrvr 打造多功能 Socket 服務器 - Delphi - bestlong 怕失憶論壇 - Powered by Discuz!
http://www.bestlong.idv.tw/forum.php?mod=viewthread&tid=1236&page=1
一個客戶端連接創建一個TSocketDispatcherThread類的服務線程為該客戶端服務，
"tsocketdispatcherthread" scktsrvr dpr A separate thread per client connection. The server scktsrvr.dpr comes with source code, see TSocketDispatcherThread in ScktMain.pas. – Ondrej ...
http://www.delphigroups.info/2/17/182900.html
How to create a socketserver service? - delphi
unit UntSocketMain;
Windows, Messages, SysUtils, Classes, Graphics, Controls, SvcMgr, Dialogs,
ScktComp, SConnect, ActiveX, MidConst, Registry, ScktCnst;
type
TSocketDispatcherThread = class(TServerClientThread, ISendDataBlock)
private
FRefCount: Integer;
FInterpreter: TDataBlockInterpreter;
FTransport: ITransport;
FInterceptGUID: string;
FLastActivity: TDateTime;
FTimeout: TDateTime;
FRegisteredOnly: Boolean;
FAllowXML: Boolean;
protected
CreateServerTransport: ITransport; virtual;
{ IUnknown }
QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
_AddRef: Integer; stdcall;
_Release: Integer; stdcall;
{ ISendDataBlock }
Send(const Data: IDataBlock; WaitForResult: Boolean):
IDataBlock; stdcall;
public
constructor Create(CreateSuspended: Boolean; ASocket:
TServerClientWinSocket;
const InterceptGUID: string; Timeout: Integer; RegisteredOnly,
AllowXML: Boolean);
procedure ClientExecute; override;
property LastActivity: TDateTime read FLastActivity;
type
TSocketDispatcher = class(TServerSocket)
private
FInterceptGUID: string;
FTimeout: Integer;
procedure GetThread(Sender: TObject; ClientSocket:
TServerClientWinSocket;
var SocketThread: TServerClientThread);
public
constructor Create(AOwner: TComponent); override;
property InterceptGUID: string read FInterceptGUID write FInterceptGUID;
property Timeout: Integer read FTimeout write FTimeout;
type
TMyService = class(TService)
procedure ServiceStart(Sender: TService; var Started: Boolean);
private
{ Private declarations }
SocketDispatcher: TSocketDispatcher;
protected
procedure ReadSettings;
public
GetServiceController: TServiceController; override;
{ Public declarations }
var
CttsoftService: TCttsoftService;
implementation
{$R *.DFM}
{ TSocketDispatcherThread }
constructor TSocketDispatcherThread.Create(CreateSuspended: Boolean;
ASocket: TServerClientWinSocket; const InterceptGUID: string; Timeout:
Integer;
RegisteredOnly, AllowXML: Boolean);
FInterceptGUID := InterceptGUID;
FTimeout := EncodeTime(Timeout div 60, Timeout mod 60, 0, 0);
FLastActivity := Now;
FRegisteredOnly := RegisteredOnly;
FAllowXML := AllowXML;
inherited Create(CreateSuspended, ASocket);
TSocketDispatcherThread.CreateServerTransport: ITransport;
var
SocketTransport: TSocketTransport;
SocketTransport := TSocketTransport.Create;
SocketTransport.Socket := ClientSocket;
SocketTransport.InterceptGUID := FInterceptGUID;
Result := SocketTransport as ITransport;
{ TSocketDispatcherThread.IUnknown }
TSocketDispatcherThread.QueryInterface(const IID: TGUID; out Obj):
HResult;
if GetInterface(IID, Obj) then Result := 0 else Result := E_NOINTERFACE;
TSocketDispatcherThread._AddRef: Integer;
Inc(FRefCount);
Result := FRefCount;
TSocketDispatcherThread._Release: Integer;
Dec(FRefCount);
Result := FRefCount;
{ TSocketDispatcherThread.ISendDataBlock }
TSocketDispatcherThread.Send(const Data: IDataBlock; WaitForResult:
Boolean): IDataBlock;
FTransport.Send(Data);
if WaitForResult then
while True do
Result := FTransport.Receive(True, 0);
if Result = nil then break;
if (Result.Signature and ResultSig) = ResultSig then
break else
FInterpreter.InterpretData(Result);
procedure TSocketDispatcherThread.ClientExecute;
var
Data: IDataBlock;
msg: TMsg;
Obj: ISendDataBlock;
Event: THandle;
WaitTime: DWord;
CoInitialize(nil);
try
FTransport := CreateServerTransport;
try
Event := FTransport.GetWaitEvent;
PeekMessage(msg, 0, WM_USER, WM_USER, PM_NOREMOVE);
GetInterface(ISendDataBlock, Obj);
if FRegisteredOnly then
FInterpreter := TDataBlockInterpreter.Create(Obj, SSockets) else
FInterpreter := TDataBlockInterpreter.Create(Obj, '');
try
Obj := nil;
if FTimeout = 0 then
WaitTime := INFINITE else
WaitTime := 60000;
while not Terminated and FTransport.Connected do
try
case MsgWaitForMultipleObjects(1, Event, False, WaitTime,
QS_ALLEVENTS) of
WAIT_OBJECT_0:
WSAResetEvent(Event);
Data := FTransport.Receive(False, 0);
if Assigned(Data) then
FLastActivity := Now;
FInterpreter.InterpretData(Data);
Data := nil;
FLastActivity := Now;
WAIT_OBJECT_0 + 1:
while PeekMessage(msg, 0, 0, 0, PM_REMOVE) do
DispatchMessage(msg);
WAIT_TIMEOUT:
if (FTimeout > 0) and ((Now - FLastActivity) > FTimeout) then
FTransport.Connected := False;
except
FTransport.Connected := False;
finally
FInterpreter.Free;
FInterpreter := nil;
finally
FTransport := nil;
finally
CoUninitialize;
{ TSocketDispatcher }
constructor TSocketDispatcher.Create(AOwner: TComponent);
inherited Create(AOwner);
ServerType := stThreadBlocking;
OnGetThread := GetThread;
procedure TSocketDispatcher.GetThread(Sender: TObject;
ClientSocket: TServerClientWinSocket;
var SocketThread: TServerClientThread);
{ SocketThread := TSocketDispatcherThread.Create(False, ClientSocket,
InterceptGUID, Timeout, SocketForm.RegisteredAction.Checked,
SocketForm.AllowXML.Checked);
Quote
}
SocketThread := TSocketDispatcherThread.Create(False, ClientSocket,
InterceptGUID, Timeout, False, True);
procedure ServiceController(CtrlCode: DWord); stdcall;
CttsoftService.Controller(CtrlCode);
TCttsoftService.GetServiceController: TServiceController;
Result := ServiceController;
procedure TMyService.ReadSettings;
SocketDispatcher := TSocketDispatcher.Create(nil);
SocketDispatcher.Port := 211;
SocketDispatcher.ThreadCacheSize := 10;
SocketDispatcher.FInterceptGUID := '';
SocketDispatcher.FTimeout := 0;
try
SocketDispatcher.Open;
except
on E: Exception do
raise Exception.CreateResFmt(@SOpenError, [SocketDispatcher.Port,
E.Message]);
procedure TMyService.ServiceStart(Sender: TService;
var Started: Boolean);
if not LoadWinSock2 then
raise Exception.CreateRes(@SNoWinSock2);
ReadSettings;
Started := True;
