You've already forked lazarus-ccr
27aea1d1ad
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@5438 8e941d3f-bd1b-0410-a28a-d453659cc2b4
1810 lines
61 KiB
ObjectPascal
1810 lines
61 KiB
ObjectPascal
{*********************************************************}
|
|
{* FlashFiler: TffLegacyTransport *}
|
|
{*********************************************************}
|
|
|
|
(* ***** BEGIN LICENSE BLOCK *****
|
|
* Version: MPL 1.1
|
|
*
|
|
* The contents of this file are subject to the Mozilla Public License Version
|
|
* 1.1 (the "License"); you may not use this file except in compliance with
|
|
* the License. You may obtain a copy of the License at
|
|
* http://www.mozilla.org/MPL/
|
|
*
|
|
* Software distributed under the License is distributed on an "AS IS" basis,
|
|
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
|
|
* for the specific language governing rights and limitations under the
|
|
* License.
|
|
*
|
|
* The Original Code is TurboPower FlashFiler
|
|
*
|
|
* The Initial Developer of the Original Code is
|
|
* TurboPower Software
|
|
*
|
|
* Portions created by the Initial Developer are Copyright (C) 1996-2002
|
|
* the Initial Developer. All Rights Reserved.
|
|
*
|
|
* Contributor(s):
|
|
*
|
|
* ***** END LICENSE BLOCK ***** *)
|
|
|
|
{$I ffdefine.inc}
|
|
|
|
unit fflllgcy;
|
|
|
|
interface
|
|
|
|
uses
|
|
dialogs,
|
|
classes,
|
|
messages,
|
|
windows,
|
|
ffdtmsgq,
|
|
ffllbase,
|
|
ffllcomp,
|
|
fflleng,
|
|
ffllcomm,
|
|
fflllog,
|
|
ffllprot,
|
|
ffllreq,
|
|
ffnetmsg;
|
|
|
|
type
|
|
|
|
TffLegacyTransportThread = class; { foward declaration }
|
|
|
|
{The purpose of this class is to give us a way of re-using the existing
|
|
protocols until better protocols can be written. It instantiates a protocol
|
|
object based upon the specified protocol type.
|
|
|
|
If Listen := False then the transport is in Send mode and is used to send
|
|
requests to a remote listener. A sender thread is used to process sending
|
|
of requests and receiving of replies. A little hoop to jump through: The
|
|
transport must do two things: wait for requests to be submitted to its
|
|
UnsentRequestQueue and allow the legacy protocol to listen for messages.
|
|
|
|
If Listen := True then the transport is in Listen mode and starts a thread
|
|
for receiving of requests. When a request is received, it processes the
|
|
request via a worker thread.
|
|
}
|
|
TffLegacyTransport = class(TffThreadedTransport)
|
|
protected {private}
|
|
{ See comments in TFFBaseTransport for _* fields }
|
|
|
|
FMsgQueue : TffDataMessageQueue;
|
|
{-When in Listen mode, used to hold partially received messages. }
|
|
|
|
FLostConnWindow : HWND;
|
|
{-Used to receive lost connection events from the protocol thread. }
|
|
|
|
FProtocol : TffBaseCommsProtocol;
|
|
{-The protocol instantiated by this transport. }
|
|
|
|
FProtocolType : TffProtocolType;
|
|
_FProtocolType : TffProtocolType;
|
|
{-The enumeration describing the protocol instantiated by this transport. }
|
|
|
|
FSendBuffer : PffnmHeader;
|
|
{-The buffer used to send messages to the remote server. }
|
|
|
|
FServerLocalName : TffNetName;
|
|
{-This is the local name portion of FServerName. For example,
|
|
if we are trying to reach 'prod1@127.0.0.1' then the server's local
|
|
name is 'prod1' and the server's address is '127.0.0.1' }
|
|
|
|
FServerAddress : TffNetName;
|
|
{-This is FServerName minus the local name of the server. For example,
|
|
if we are trying to reach 'prod1@127.0.0.1' then the server's local
|
|
name is 'prod1' and FServerAddress will be '127.0.0.1' }
|
|
|
|
FTransportThread : TffLegacyTransportThread;
|
|
{-If in Listen mode, this is the thread that is listening. If in Send
|
|
mode, this is the thread that will be sending requests. }
|
|
|
|
protected
|
|
|
|
procedure btBeginUpdatePrim; override;
|
|
|
|
procedure btEndUpdatePrim; override;
|
|
|
|
function btGetConnectionID(const anIndex : Longint) : TffClientID; override;
|
|
{ Used to obtain the IDs of the protocol's connections. Handy for when
|
|
a server wants to send messages to one or more client connections. }
|
|
|
|
procedure btInternalReply(msgID : Longint;
|
|
errorCode : TffResult;
|
|
replyData : pointer;
|
|
replyDataLen : Longint); override;
|
|
{ This method is called from TffBaseTransport.Reply. It sends the
|
|
reply to the client. }
|
|
|
|
procedure btSetRespondToBroadcasts(const respond : boolean); override;
|
|
{ This implementation makes sure the legacy protocol is configured
|
|
properly if RespondToBroadcasts is changed while the transport is
|
|
active. }
|
|
|
|
procedure btSetServername(const aServername : string); override; {!!.10}
|
|
{-This method sets the server name. The implementation for this class
|
|
does not perform any validation. Transport subclasses should perform
|
|
their own validation. }
|
|
|
|
procedure lcLog(const aMsg : string); override;
|
|
{ Use this method to write an error string to the event log. }
|
|
|
|
procedure ltFreeMsg(msg : PffDataMessage); virtual; {!!.01}
|
|
|
|
function ltGetProtocol : TffProtocolType; virtual;
|
|
{ Used to get the legacy protocol. }
|
|
|
|
{Begin !!.01}
|
|
procedure ltDoHangup(const aClientID : TffClientID);
|
|
{ Hangup processing. }
|
|
{End !!.01}
|
|
|
|
procedure ltLostConnection(var aMsg : TMessage);
|
|
{ Message handler for lost connections window. }
|
|
|
|
function ltMapProtocolToClass : TffCommsProtocolClass;
|
|
{ Maps the transport's protocol to its protocol class. }
|
|
|
|
procedure lcSetEventLog(anEventLog : TffBaseLog); override;
|
|
{ Set the transport's event log. This overridden method makes sure the
|
|
protocol's EventLog property is kept up-to-date. }
|
|
|
|
procedure lcSetLogEnabled(const aEnabled : Boolean); override;
|
|
{ This overridden method updates the logEnabled property of the
|
|
TffBaseCommsProtocol instance created by this component. }
|
|
|
|
procedure ltSetProtocol(aProtocol : TffProtocolType); virtual;
|
|
{ Used to set the legacy protocol. }
|
|
|
|
{Begin !!.05}
|
|
procedure ltTerminateThread;
|
|
{ Terminate the transport thread if it is active. }
|
|
{End !!.05}
|
|
|
|
procedure scInitialize; override;
|
|
{ Called when the transport is to initialize itself for operation. This
|
|
implementation creates and initializes the protocol and transport
|
|
thread. }
|
|
|
|
procedure scPrepareForShutdown; override;
|
|
{ This method is called when the transport is to prepare for shutdown. }
|
|
|
|
procedure scShutdown; override;
|
|
{ This method is called when the transport is to shut down. }
|
|
|
|
procedure scStartup; override;
|
|
{ This method is called when the transport is to start up. }
|
|
|
|
procedure tpConnectionLost(aSender : TObject;
|
|
aClientID : TffClientID);
|
|
{-Called when the transport is sending and the remote server engine
|
|
unexpectedly hangs up on the client. This method is called within the
|
|
context of the transport thread. It sends a message to the
|
|
transports lost connection window and the message is then processed
|
|
by ltLostConnection. }
|
|
|
|
procedure tpDatagramReceived(aSender : TObject;
|
|
const aName : TffNetName;
|
|
aData : PffByteArray;
|
|
aDataLen : Longint);
|
|
{ Used to log receipt of broadcast requests in listening transport. }
|
|
|
|
function tpGetCodeStart(const aClientID : TffClientID) : integer;
|
|
{ Used to obtain the starting encryption code for the specified client. }
|
|
|
|
procedure tpHandleAddClient(aMsg : PffDataMessage);
|
|
{-This method is called by a listening transport to process the adding
|
|
of a new client. }
|
|
|
|
procedure tpHandleNextRequest;
|
|
{-This method is used to handle the next unsent request. The request
|
|
is moved from the unsent queue to the waiting for reply list. }
|
|
|
|
procedure tpHandleRemoveClient(aMsg : PffDataMessage);
|
|
{-This method is called by a listening transport to process the removal
|
|
of an existing client. }
|
|
|
|
procedure tpInternalRequest(aRequest : TffRequest;
|
|
timeout : Longint;
|
|
aCookie : HWND); override;
|
|
{-Internal method for sending a request. This implementation assigns the
|
|
protocol's event log to the request and assigns the protocol's window
|
|
handle to the value of aCookie. }
|
|
|
|
function tpMsgReceived(aSender : TObject;
|
|
clientID : TffClientID;
|
|
msgData : PffByteArray;
|
|
msgDataLen : Longint) : boolean;
|
|
{-This method is called when a request is received from a client or
|
|
when a reply is received from a server. }
|
|
|
|
procedure tpPrepareThread;
|
|
{ Prepares the legacy transport thread for work. }
|
|
|
|
procedure tpProcessCallback(const aProcessCookie : Longint); virtual;
|
|
{ When in Listen mode, this method is called by the worker thread to
|
|
process the request received from the client.
|
|
This method stores information such as the clientID and requestID in
|
|
threadvars so that it may be used when replying to the client.
|
|
aProcessCookie is a pointer to the message received from the client.
|
|
The method passes the message to the command handler.
|
|
}
|
|
|
|
procedure tpRemoteClientHangup(aSender : TObject;
|
|
aClientID : TffClientID);
|
|
{-Called when the transport is listening and a) the client hangs up
|
|
or b) the transport decides to hang up on the client. }
|
|
|
|
function tpReplyReceived(aSender : TObject;
|
|
clientID : TffClientID;
|
|
replyData : PffByteArray;
|
|
replyDataLen : Longint) : boolean; virtual;
|
|
{ When sending, this method is called when the legacy protocol has
|
|
received a reply from the server. In this implementation the
|
|
following occurs:
|
|
1. If this reply is acknowledging the last message was received then
|
|
the request is sitting in the pending list. Find the request and
|
|
put it in the Unsent Requests queue.
|
|
|
|
2. If this reply is a full-fledged response to a complete message, do
|
|
the following:
|
|
|
|
a. Find the TffRequest.
|
|
b. Place the reply data on the request.
|
|
c. Remove the request from the WaitingForReply list.
|
|
d. Call TffRequest.WakeUpThread.
|
|
}
|
|
|
|
function tpRequestReceived(aSender : TObject;
|
|
clientID : TffClientID;
|
|
requestData : PffByteArray;
|
|
requestDataLen : Longint) : boolean; virtual;
|
|
{ When listening, this method is called when the protocol thread has
|
|
received a request from a client. The transport then spawns a worker
|
|
thread that performs the actual work. }
|
|
|
|
function tpSendReply(msgID : Longint;
|
|
clientID : TffClientID;
|
|
requestID : Longint;
|
|
errorCode : TffResult;
|
|
replyData : pointer;
|
|
replyDataLen : Longint) : TffResult;
|
|
{ This method sends the actual reply to the client. The reply is
|
|
sent in context of the thread that processed the client's request,
|
|
not the listening thread. }
|
|
|
|
function tpSendRequest(aRequest : TffRequest) : TffResult;
|
|
{ Sends a request via the protocol to the remove server. This method
|
|
returns DBIERR_NONE if the request was successfully sent. }
|
|
|
|
procedure tpShutdownProtocol;
|
|
{ This method is called when the protocol thread stops executing.
|
|
It must be run in context of the protocol thread so that any
|
|
thread-specific items (e.g., windows, timers) may be destroyed. }
|
|
|
|
procedure tpStartProtocol;
|
|
{ This method is called when the protocol thread begins execution.
|
|
It must be run in context of the protocol thread so that the
|
|
window handle created by the protocol is associated with the
|
|
thread. }
|
|
|
|
procedure tpThreadTerminated(Sender : TObject);
|
|
{ This method is called when the transport thread terminates.
|
|
The purpose of this handler is to detect the case where the
|
|
thread terminates prematurely. }
|
|
|
|
public
|
|
|
|
constructor Create(aOwner : TComponent); override;
|
|
destructor Destroy; override;
|
|
|
|
function ConnectionCount : Longint; override;
|
|
{ Returns the number of established connections. For a sender (i.e.,
|
|
client), this will be the number of connections to the remote server.
|
|
For a listener (i.e., server), this will be the number of
|
|
connections establshed by remote clients. }
|
|
|
|
function EstablishConnection(const aUserName : TffName;
|
|
aPasswordHash : integer;
|
|
aTimeout : Longint;
|
|
var aClientID : TffClientID ) : TffResult; override;
|
|
{ Use this method to establish a connection with the server. If the
|
|
return code is DBIERR_NONE then aClientID will contain the clientID
|
|
supplied by the server. This clientID must be used in all subsequent
|
|
requests to the server. }
|
|
|
|
function GetName : string; override;
|
|
{ Returns the transport's name. }
|
|
|
|
procedure GetServerNames(aList : TStrings; const timeout : Longint); override;
|
|
{ Returns the list of servers available via this transport. }
|
|
|
|
function IsConnected : boolean; override;
|
|
{ Use this method to determine if the transport is connected to a remote
|
|
server. It is considered connected if a) the transport's State is
|
|
ffesStarted and b) there is at least one established connection.
|
|
If the transport has been started but no connections have been
|
|
established then this method returns False. }
|
|
|
|
procedure Request(transportID : Longint;
|
|
clientID : TffClientID;
|
|
msgID : Longint;
|
|
timeout : Longint;
|
|
requestData : pointer;
|
|
requestDataLen : Longint;
|
|
replyCallback : TffReplyCallback;
|
|
replyCookie : Longint); override;
|
|
{ When the transport is in Send mode, call this method in order to
|
|
submit a request to the transport.
|
|
|
|
Parameters are as follows:
|
|
|
|
@param transportID - For use by future transports.
|
|
@param clientID - The ID of the client submitting the request. This
|
|
must be the clientID originally supplied by the server or it may be
|
|
zero for unsecured calls (e.g., initially asking for a connection
|
|
to the server).
|
|
@param msgID - The type of message being sent.
|
|
@param timeout - The number of milliseconds in which a reply must be
|
|
received from the server.
|
|
@param requestData - Pointer to a data buffer containing the message
|
|
data.
|
|
@param requestDataLen - The length of requestData.
|
|
@param replyCallback - The procedure to be called when the reply
|
|
has been received from the server.
|
|
@param replyCookie - Whatever the calling object wants it to be. This
|
|
parameter is supplied to the replyCallback.
|
|
}
|
|
|
|
function Supported : boolean; override;
|
|
{ Use this method to determine if the transport's current protocol is
|
|
supported on the workstation. Returns True if the protocol is
|
|
supported otherwise returns False. }
|
|
|
|
procedure TerminateConnection(const aClientID : TffClientID;
|
|
const timeout : Longint); override;
|
|
{ Use this method to terminate a connection with the server. aClientID
|
|
is the clientID originally returned in the call to EstablishConnection.}
|
|
|
|
procedure Work; override;
|
|
{ Based upon the transport's mode, this method tells the transport to
|
|
perform some work:
|
|
|
|
1. When in sending mode, sends requests and processes replies
|
|
2. When in listening mode, listens for requests.
|
|
|
|
This method should be structured such that it does a bit of work and
|
|
then returns. It is to be repeatedly called from the
|
|
TffLegacyTransportThread.Execute method so that the Execute method
|
|
may check the thread's Terminated property.
|
|
}
|
|
|
|
published
|
|
|
|
property Protocol : TffProtocolType
|
|
read ltGetProtocol
|
|
write ltSetProtocol
|
|
default ptRegistry;
|
|
{ The legacy protocol to be used by this transport. Defaults to
|
|
ptRegistry. }
|
|
|
|
end;
|
|
|
|
{ In order to support sending and receiving of messages without blocking
|
|
the client application or server, the legacy transport carries out
|
|
sending and receiving of messages through an instance of this class.
|
|
|
|
The thread is always created in suspended mode. It is resumed by
|
|
TffLegacyTransport.tpStartup.
|
|
}
|
|
TffLegacyTransportThread = class(TffThread)
|
|
private
|
|
FTransport : TffLegacyTransport;
|
|
{ The transport starting this thread. }
|
|
FUnexpectedTermination : boolean;
|
|
{ Set to True if thread terminated by an exception. }
|
|
protected
|
|
|
|
procedure Execute; override;
|
|
{ This method repeatedly calls the transport's Work method. Execute
|
|
should be called only when the transport's Startup method is called. }
|
|
|
|
public
|
|
|
|
constructor Create(aTransport : TffLegacyTransport);
|
|
{ When creating a listener thread, the parent transport is identified.
|
|
The thread is suspended. }
|
|
|
|
property UnexpectedTermination : boolean read FUnexpectedTermination;
|
|
|
|
end;
|
|
|
|
implementation
|
|
|
|
uses
|
|
forms,
|
|
sysutils,
|
|
ffclcfg,
|
|
ffllexcp,
|
|
ffllthrd,
|
|
ffllwsck,
|
|
ffsrbase,
|
|
ffsrbde
|
|
{$ifdef fpc},LCLIntf{$endif}; //soner LCLIntf for functions AllocateHWnd and DeallocateHWnd
|
|
|
|
{$I ffconst.inc}
|
|
|
|
const
|
|
ffc_ThreadDoneTimeout = 1000; { # milliseconds to wait for send/listen
|
|
thread to shutdown }
|
|
ffc_ThreadStartTimeout = 2000; { # milliseconds to wait for the transport
|
|
thread to start }
|
|
ffc_SingleUserServerName = 'Local';
|
|
|
|
{ Prefixes for logging requests. }
|
|
ffc_Post = 'Post';
|
|
ffc_PostWait = 'Post&Wait';
|
|
ffc_Request = 'Req';
|
|
|
|
{ Error messages. }
|
|
ffc_ErrMsgType = 'Bad msg type %d, Clnt %d, Msg %d';
|
|
|
|
{===TffLegacyTransport===============================================}
|
|
|
|
threadvar
|
|
ffitvClientID : TffClientID;
|
|
ffitvRequestID : Longint;
|
|
|
|
constructor TffLegacyTransport.Create(aOwner : TComponent);
|
|
begin
|
|
inherited Create(aOwner);
|
|
FLogEnabled := False;
|
|
{$IFDEF DCC6OrLater}
|
|
{$WARN SYMBOL_DEPRECATED OFF}
|
|
{$ENDIF}
|
|
{$ifdef fpc}
|
|
FLostConnWindow := LCLIntf.AllocateHWND(ltLostConnection); //soner
|
|
{$else}
|
|
FLostConnWindow := AllocateHWND(ltLostConnection);
|
|
{$endif}
|
|
{$IFDEF DCC6OrLater}
|
|
{$WARN SYMBOL_DEPRECATED ON}
|
|
{$ENDIF}
|
|
FProtocol := nil;
|
|
FProtocolType := ptRegistry;
|
|
FTransportThread := nil;
|
|
FSendBuffer := nil;
|
|
end;
|
|
{--------}
|
|
destructor TffLegacyTransport.Destroy;
|
|
begin
|
|
FFNotifyDependents(ffn_Destroy);
|
|
ltTerminateThread; {!!.05}
|
|
{$IFDEF DCC6OrLater}
|
|
{$WARN SYMBOL_DEPRECATED OFF}
|
|
{$ENDIF}
|
|
{$ifdef fpc}
|
|
LCLIntf.DeallocateHWnd(FLostConnWindow); //soner
|
|
{$else}
|
|
DeallocateHWnd(FLostConnWindow);
|
|
{$endif}
|
|
{$IFDEF DCC6OrLater}
|
|
{$WARN SYMBOL_DEPRECATED ON}
|
|
{$ENDIF}
|
|
inherited Destroy;
|
|
end;
|
|
{--------}
|
|
procedure TffLegacyTransport.btBeginUpdatePrim;
|
|
begin
|
|
inherited btBeginUpdatePrim;
|
|
|
|
{ Set the _* fields to match their counterparts }
|
|
_FProtocolType := FProtocolType;
|
|
end;
|
|
{--------}
|
|
procedure TffLegacyTransport.btEndUpdatePrim;
|
|
begin
|
|
{ Update the fields with their _* counterparts. }
|
|
{ All property write methods are required to check that the new value }
|
|
{ does not match the old value! }
|
|
Protocol := _FProtocolType;
|
|
if Protocol = ptSingleUser then
|
|
_FServerName := ServerName;
|
|
|
|
if assigned(FProtocol) then
|
|
FProtocol.LogEnabled := _FLogEnabled;
|
|
|
|
inherited btEndUpdatePrim;
|
|
end;
|
|
{--------}
|
|
function TffLegacyTransport.btGetConnectionID(const anIndex : Longint) : TffClientID;
|
|
begin
|
|
Result := FProtocol.ConnectionIDs[anIndex];
|
|
end;
|
|
{--------}
|
|
function TffLegacyTransport.ConnectionCount : Longint;
|
|
begin
|
|
if assigned(FProtocol) then
|
|
Result := FProtocol.ConnectionCount
|
|
else
|
|
Result := 0;
|
|
end;
|
|
{--------}
|
|
function TffLegacyTransport.EstablishConnection
|
|
(const aUserName : TffName;
|
|
aPasswordHash : integer;
|
|
aTimeout : Longint;
|
|
var aClientID : TffClientID ) : TffResult;
|
|
var
|
|
aRequest : TffRequest;
|
|
AttachReq : TffnmAttachServerReq;
|
|
CallReq : TffnmCallServerReq;
|
|
PAttachRpy : PffnmAttachServerRpy;
|
|
begin
|
|
|
|
btCheckSender;
|
|
btCheckServerName;
|
|
scCheckStarted;
|
|
|
|
{ Have the protocol contact the server.
|
|
Note that we will get back a temporary clientID from the protocol.
|
|
This temporary ID will be replaced once we have a good one from
|
|
the server. }
|
|
CallReq.ServerName := FServerAddress;
|
|
aRequest := TffRequest.Create(aClientID, ffnmCallServer, @CallReq,
|
|
sizeOf(CallReq), aTimeout, ffrmReplyExpected);
|
|
try
|
|
tpInternalRequest(aRequest, aTimeout, FProtocol.NotifyWindow);
|
|
Result := aRequest.ErrorCode;
|
|
if Result <> DBIERR_NONE then begin
|
|
aRequest.Free;
|
|
exit;
|
|
end;
|
|
except
|
|
{ If an exception occurs then the transport thread is responsible for
|
|
freeing the request. }
|
|
on E:EffException do begin
|
|
Result := E.ErrorCode;
|
|
exit;
|
|
end else
|
|
raise;
|
|
end;
|
|
|
|
{ Connection successful. Get the clientID from the server. }
|
|
Assert(assigned(aRequest.ReplyData));
|
|
aClientID := PffnmCallServerRpy(aRequest.ReplyData)^.ClientID;
|
|
aRequest.Free;
|
|
|
|
{ Obtain permission to attach a client. }
|
|
with AttachReq do begin
|
|
ClientName := aUserName;
|
|
UserID := aUserName;
|
|
Timeout := aTimeout;
|
|
ClientVersion := ffVersionNumber;
|
|
end;
|
|
|
|
{ Submit the request. }
|
|
aRequest := TffRequest.Create(aClientID, ffnmAttachServer, @AttachReq,
|
|
sizeOf(AttachReq), aTimeout, ffrmReplyExpected);
|
|
try
|
|
tpInternalRequest(aRequest, aTimeout, FProtocol.NotifyWindow);
|
|
except
|
|
{ If an exception occurs then the transport thread is responsible for
|
|
freeing the request. }
|
|
on E:EffException do begin
|
|
Result := E.ErrorCode;
|
|
exit;
|
|
end else
|
|
raise;
|
|
end;
|
|
|
|
{ Evaluate the reply. }
|
|
Result := aRequest.ErrorCode;
|
|
if Result = DBIERR_NONE then begin
|
|
pAttachRpy := PffnmAttachServerRpy(aRequest.ReplyData);
|
|
with pAttachRpy^ do begin
|
|
{ Have the protocol update our connection's clientID. }
|
|
FProtocol.UpdateClientID(aClientID, ClientID);
|
|
aClientID := ClientID;
|
|
|
|
if IsSecure then
|
|
FProtocol.InitCode(aClientID, Code xor Longint(aPasswordHash))
|
|
else
|
|
FProtocol.InitCode(aClientID, Code);
|
|
|
|
{Update the protocol's keep alive information. }
|
|
FProtocol.KeepAliveInterval := KAIntvl;
|
|
FProtocol.KeepAliveRetries := KARetries;
|
|
FProtocol.LastMsgInterval := LastMsgIntvl;
|
|
FProtocol.ResetKeepAliveTimer; {!!.06}
|
|
|
|
{ Check secure communications...}
|
|
aRequest.Free;
|
|
aRequest := TffRequest.Create(aClientID, ffnmCheckSecureComms, nil, 0,
|
|
aTimeout, ffrmReplyExpected);
|
|
try
|
|
tpInternalRequest(aRequest, aTimeout, FProtocol.NotifyWindow);
|
|
except
|
|
{ If an exception occurs then the transport thread is responsible for
|
|
freeing the request. }
|
|
on E:EffException do begin
|
|
Result := E.ErrorCode;
|
|
exit;
|
|
end else
|
|
raise;
|
|
end;
|
|
Result := aRequest.ErrorCode;
|
|
if Result <> DBIERR_NONE then begin
|
|
{ The password is bogus. }
|
|
FProtocol.HangUpByClientID(aClientID);
|
|
if Result <> fferrReplyTimeout then {!!.06}
|
|
Result := DBIERR_INVALIDUSRPASS; {!!.06}
|
|
end; { if }
|
|
end; { with }
|
|
end else
|
|
{ Server rejected us. Tell protocol to get rid of the connection. }
|
|
FProtocol.HangUpByClientID(aClientID);
|
|
|
|
{Begin !!.06}
|
|
{ If timed out waiting for a reply then we need to remove this request from
|
|
the waiting for reply queue. }
|
|
if Result = fferrReplyTimeout then
|
|
with FWaitingForReplyList.BeginWrite do
|
|
try
|
|
Delete(Longint(aRequest));
|
|
finally
|
|
EndWrite;
|
|
end;
|
|
{End !!.06}
|
|
|
|
if assigned(aRequest) then
|
|
aRequest.Free;
|
|
|
|
end;
|
|
{Begin !!.01}
|
|
{--------}
|
|
procedure TffLegacyTransport.ltFreeMsg(msg : PffDataMessage);
|
|
begin
|
|
if Msg^.dmDataLen > 0 then
|
|
FFFreeMem(Msg^.dmData, Msg^.dmDataLen);
|
|
FFFreeMem(Msg, SizeOf(TffDataMessage));
|
|
end;
|
|
{End !!.01}
|
|
{--------}
|
|
procedure TffLegacyTransport.ltLostConnection(var aMsg : TMessage);
|
|
begin
|
|
{ Lost connection message? Event handler declared? }
|
|
if (aMsg.Msg = ffm_LostConnection) then begin {!!.01}
|
|
if assigned(FOnConnectionLost) then begin
|
|
FOnConnectionLost(Self, aMsg.wParam)
|
|
end else
|
|
if csDesigning in ComponentState then
|
|
AutoConnectionLost(Self, aMsg.WParam);
|
|
end {!!.01}
|
|
else if aMsg.Msg = WM_QUERYENDSESSION then {!!.01}
|
|
aMsg.Result := 1 {!!.01}
|
|
else {!!.01}
|
|
Dispatch(aMsg); {!!.01}
|
|
end;
|
|
{--------}
|
|
function TffLegacyTransport.ltMapProtocolToClass : TffCommsProtocolClass;
|
|
var
|
|
protName : TffShStr;
|
|
begin
|
|
if (FProtocolType <> ptRegistry) then begin
|
|
case Protocol of
|
|
ptSingleUser : Result := TffSingleUserProtocol;
|
|
ptTCPIP : Result := TffTCPIPProtocol;
|
|
ptIPXSPX : Result := TffIPXSPXProtocol;
|
|
else
|
|
Result := TffSingleUserProtocol;
|
|
end;
|
|
end
|
|
else
|
|
FFClientConfigReadProtocol(Result, protName);
|
|
end;
|
|
{--------}
|
|
function TffLegacyTransport.GetName : string;
|
|
begin
|
|
Result := ltMapProtocolToClass.GetProtocolName;
|
|
end;
|
|
{--------}
|
|
procedure TffLegacyTransport.GetServerNames(aList : TStrings;
|
|
const timeout : Longint);
|
|
var
|
|
OldServerNameRequired : boolean;
|
|
OldState : TffState;
|
|
begin
|
|
|
|
if not assigned(aList) then
|
|
Exit;
|
|
|
|
OldState := scState;
|
|
OldServerNameRequired := false;
|
|
|
|
{ If the transport has not been started, temporarily start the transport. }
|
|
if OldState <> ffesStarted then begin
|
|
OldServerNameRequired := FServerNameRequired;
|
|
FServerNameRequired := false;
|
|
State := ffesStarted;
|
|
end;
|
|
|
|
{ Note: This is done outside the transport's sender thread. It should
|
|
not interfere with the sender thread's normal operation. }
|
|
{Begin !!.05}
|
|
if Assigned(FProtocol) then
|
|
FProtocol.GetServerNames(aList, timeout)
|
|
else
|
|
aList.Clear;
|
|
{End !!.05}
|
|
|
|
{ Restore transport to original state. }
|
|
if OldState <> ffesStarted then begin
|
|
State := OldState;
|
|
FServerNameRequired := OldServerNameRequired;
|
|
end;
|
|
|
|
end;
|
|
{--------}
|
|
procedure TffLegacyTransport.btInternalReply(msgID : Longint;
|
|
errorCode : TffResult;
|
|
replyData : pointer;
|
|
replyDataLen : Longint);
|
|
begin
|
|
inherited btInternalReply(msgID, errorCode, replyData, replyDataLen);
|
|
tpSendReply(msgID, ffitvClientID, ffitvRequestID, errorCode,
|
|
replyData, replyDataLen);
|
|
end;
|
|
{--------}
|
|
function TffLegacyTransport.IsConnected : boolean;
|
|
begin
|
|
{ We are connected if we are in the right state and there is at least one
|
|
established connection. }
|
|
Result := (scState = ffesStarted) and (FProtocol.ConnectionCount > 0);
|
|
end;
|
|
{--------}
|
|
procedure TffLegacyTransport.lcLog(const aMsg : string);
|
|
begin
|
|
if FLogEnabled and assigned(FEventLog) and (fftpLogErrors in FLogOptions) then
|
|
FEventLog.WriteString(aMsg);
|
|
end;
|
|
{--------}
|
|
procedure TffLegacyTransport.lcSetLogEnabled(const aEnabled : Boolean);
|
|
begin
|
|
inherited lcSetLogEnabled(aEnabled);
|
|
if (UpdateCount = 0) and assigned(FProtocol) then
|
|
FProtocol.LogEnabled := aEnabled;
|
|
end;
|
|
{--------}
|
|
function TffLegacyTransport.ltGetProtocol : TffProtocolType;
|
|
begin
|
|
Result := FProtocolType;
|
|
end;
|
|
{Begin !!.01}
|
|
{--------}
|
|
type
|
|
ProtocolCracker = class(TffBaseCommsProtocol);
|
|
|
|
procedure TffLegacyTransport.ltDoHangup(const aClientID : TffClientID);
|
|
{Rewritten !!.05}
|
|
var
|
|
conn : TffConnection;
|
|
errorCode : TffResult;
|
|
begin
|
|
conn := ProtocolCracker(FProtocol).cpGetConnection(aClientID);
|
|
if Assigned(conn) and (not conn.HangupDone) then begin
|
|
if assigned(FOnRemoveClient) then
|
|
FOnRemoveClient(Self, aClientID, errorCode)
|
|
else
|
|
{ No handler assigned. Log an error. }
|
|
lcLogFmt('No RemoveClientHandler for transport %d', [GetName]);
|
|
conn.HangupDone := True;
|
|
end;
|
|
end;
|
|
{End !!.01}
|
|
{--------}
|
|
procedure TffLegacyTransport.ltSetProtocol(aProtocol : TffProtocolType);
|
|
begin
|
|
if (UpdateCount > 0) then
|
|
_FProtocolType := aProtocol
|
|
else begin
|
|
{Check to make sure the new property is different.}
|
|
if FProtocolType = aProtocol then Exit;
|
|
|
|
{Note: If you ever remove the following requirement, update the Supported
|
|
test at the end of this routine. }
|
|
scCheckInactive;
|
|
FProtocolType := aProtocol;
|
|
if FProtocolType = ptSingleUser then begin
|
|
FServerNameRequired := False;
|
|
ServerName := ffc_SingleUserServerName;
|
|
end;
|
|
|
|
{ Is this protocol supported on the workstation? }
|
|
if Supported then
|
|
scState := ffesInactive
|
|
else
|
|
scState := ffesUnsupported;
|
|
end;
|
|
end;
|
|
{Begin !!.05}
|
|
{--------}
|
|
procedure TffLegacyTransport.ltTerminateThread;
|
|
begin
|
|
if assigned(FTransportThread) then begin
|
|
FTransportThread.Terminate;
|
|
FTransportThread.WaitForEx(5000);
|
|
FTransportThread.Free;
|
|
FTransportThread := nil;
|
|
end;
|
|
end;
|
|
{End !!.05}
|
|
{--------}
|
|
procedure TffLegacyTransport.btSetRespondToBroadcasts(const respond : boolean);
|
|
var
|
|
OldValue : boolean;
|
|
begin
|
|
OldValue := FRespondToBroadcasts;
|
|
inherited btSetRespondToBroadcasts(respond);
|
|
if (OldValue <> FRespondToBroadcasts) and
|
|
(scState = ffesStarted) then
|
|
if respond then
|
|
FProtocol.ReceiveDatagram
|
|
else
|
|
FProtocol.StopReceiveDatagram;
|
|
end;
|
|
{--------}
|
|
procedure TffLegacyTransport.btSetServerName(const aServerName : string); {!!.10}
|
|
begin
|
|
inherited btSetServerName(aServerName);
|
|
FFSplitNetAddress(aServerName, FServerLocalName, FServerAddress);
|
|
end;
|
|
{--------}
|
|
procedure TffLegacyTransport.lcSetEventLog(anEventLog : TffBaseLog);
|
|
begin
|
|
inherited lcSetEventLog(anEventLog);
|
|
if assigned(FProtocol) then
|
|
FProtocol.EventLog := anEventLog;
|
|
end;
|
|
{--------}
|
|
procedure TffLegacyTransport.Request(transportID : Longint;
|
|
clientID : TffClientID;
|
|
msgID : Longint;
|
|
timeout : Longint;
|
|
requestData : pointer;
|
|
requestDataLen : Longint;
|
|
replyCallback : TffReplyCallback;
|
|
replyCookie : Longint);
|
|
var
|
|
aRequest : TffRequest;
|
|
|
|
begin
|
|
scCheckStarted;
|
|
aRequest := TffRequest.Create(clientID, msgID, requestData, requestDataLen,
|
|
timeout, ffrmReplyExpected);
|
|
tpInternalRequest(aRequest, timeout, FProtocol.NotifyWindow);
|
|
if assigned(replyCallback) then
|
|
replyCallback(aRequest.ReplyMsgID, aRequest.ErrorCode,
|
|
aRequest.ReplyData, aRequest.ReplyDataLen,
|
|
replyCookie);
|
|
if not aRequest.Aborted then
|
|
aRequest.Free
|
|
else
|
|
with aRequest do
|
|
tpLogReqMisc(format(ffc_ReqAborted,[Longint(aRequest), ClientID,
|
|
ErrorCode, Timeout]));
|
|
end;
|
|
{--------}
|
|
procedure TffLegacyTransport.scInitialize;
|
|
var
|
|
protClass : TffCommsProtocolClass;
|
|
whichSideOfTheCoin : TffClientServerType;
|
|
begin
|
|
|
|
{ Make sure the old protocol is freed. }
|
|
if assigned(FProtocol) then begin
|
|
if FProtocol.IsStarted then begin
|
|
scPrepareForShutdown;
|
|
scShutdown;
|
|
end;
|
|
end;
|
|
|
|
{ If we are in sending mode then verify we have a target server. }
|
|
if FMode = fftmSend then
|
|
btCheckServerName;
|
|
|
|
{ Figure out which type of protocol we are to instantiate. }
|
|
protClass := ltMapProtocolToClass;
|
|
|
|
if assigned(FMsgQueue) then begin
|
|
FMsgQueue.Free;
|
|
FMsgQueue := nil;
|
|
end;
|
|
|
|
{ Figure out the protocol's mode. }
|
|
if FMode = fftmListen then
|
|
whichSideOfTheCoin := csServer
|
|
else
|
|
whichSideOfTheCoin := csClient;
|
|
|
|
FMsgQueue := TffDataMessageQueue.Create;
|
|
|
|
FProtocol := protClass.Create(FServerName, whichSideOfTheCoin);
|
|
if FMode = fftmListen then
|
|
with FProtocol do begin
|
|
OnConnectionLost := tpRemoteClientHangup;
|
|
OnHangUp := tpRemoteClientHangup;
|
|
OnHeardCall := nil;
|
|
OnReceiveDatagram := tpDatagramReceived;
|
|
OnReceiveMsg := tpMsgReceived;
|
|
end
|
|
else
|
|
with FProtocol do begin
|
|
OnConnectionLost := tpConnectionLost;
|
|
OnHangUp := nil;
|
|
OnHeardCall := nil;
|
|
OnReceiveDatagram := nil;
|
|
OnReceiveMsg := tpMsgReceived;
|
|
end;
|
|
|
|
FProtocol.EventLog := FEventLog; {!!.01}
|
|
FProtocol.LogEnabled := FLogEnabled;
|
|
|
|
{ If we are listening then get our servername from the protocol. }
|
|
if FMode = fftmListen then
|
|
FServerName := FProtocol.NetName;
|
|
|
|
FFGetMem(FSendBuffer, FProtocol.MaxNetMsgSize);
|
|
|
|
tpPrepareThread;
|
|
|
|
end;
|
|
{--------}
|
|
procedure TffLegacyTransport.scPrepareForShutdown;
|
|
{Rewritten !!.05}
|
|
begin
|
|
ltTerminateThread;
|
|
end;
|
|
{--------}
|
|
procedure TffLegacyTransport.scShutdown;
|
|
begin
|
|
try
|
|
{ Note: We can't free the protocol or the thread until we know they have
|
|
finished or a certain number of milliseconds has elapsed. }
|
|
ltTerminateThread; {!!.05}
|
|
finally
|
|
|
|
{Begin !!.03}
|
|
if assigned(FSendBuffer) then begin
|
|
FFFreeMem(FSendBuffer, FProtocol.MaxNetMsgSize);
|
|
FSendBuffer := nil;
|
|
end;
|
|
{End !!.03}
|
|
|
|
if assigned(FMsgQueue) then begin
|
|
FMsgQueue.Free;
|
|
FMsgQueue := nil;
|
|
end;
|
|
|
|
if assigned(FProtocol) then begin
|
|
FProtocol.Free;
|
|
FProtocol := nil;
|
|
end;
|
|
|
|
if assigned(FTransportThread) then
|
|
{ By this time, the transport thread will have freed itself. }
|
|
FTransportThread := nil;
|
|
end;
|
|
end;
|
|
{--------}
|
|
procedure TffLegacyTransport.scStartup;
|
|
begin
|
|
FTransportThread.Resume;
|
|
|
|
{ An exception during protocol startup might leave the thread in a terminated
|
|
state. If the thread is still going, wait for the thread to finish or fail
|
|
startup. }
|
|
if (not FTransportThread.Terminated) then
|
|
FProtocol.StartedEvent.WaitFor(ffc_ThreadStartTimeout);
|
|
|
|
{ If the thread fails then raise an exception. }
|
|
if not FProtocol.IsStarted then
|
|
raise EffException.CreateEx(ffStrResGeneral, fferrProtStartupFail,
|
|
[(FProtocol as TffBaseCommsProtocol).GetProtocolName]);
|
|
|
|
end;
|
|
{--------}
|
|
function TffLegacyTransport.Supported : boolean;
|
|
begin
|
|
Result := ltMapProtocolToClass.Supported;
|
|
end;
|
|
{--------}
|
|
procedure TffLegacyTransport.TerminateConnection(const aClientID : TffClientID;
|
|
const timeout : Longint);
|
|
begin
|
|
{Begin delete !!.05}
|
|
{ Post a message to the server stating that we are hanging up. }
|
|
// Post(0, aClientID, ffnmDetachServer, nil, 0, timeout, ffrmNoReplyWaitUntilSent);
|
|
{ After we know the message has been sent, tell the protocol to hangup. }
|
|
{End delete !!.05}
|
|
{ Tell the protocol to hangup. } {!!.05}
|
|
if assigned(FProtocol) then
|
|
FProtocol.HangUpByClientID(aClientID);
|
|
end;
|
|
{--------}
|
|
procedure TffLegacyTransport.tpConnectionLost(aSender : TObject;
|
|
aClientID : TffClientID);
|
|
{Begin !!.01}
|
|
var
|
|
anInx : Longint;
|
|
aRequest : TffRequest;
|
|
{End !!.01}
|
|
RequestFound : Boolean;
|
|
begin
|
|
// PostMessage(FLostConnWindow, ffm_LostConnection, aClientID, 0); {Deleted !!.12}
|
|
{Begin !!.01}
|
|
{ Abort the request pending for this client. There should be only one pending
|
|
request for the client at any one time. }
|
|
with FWaitingForReplyList.BeginRead do
|
|
try
|
|
RequestFound := False; {!!.13}
|
|
for anInx := 0 to pred(Count) do begin
|
|
aRequest := TffRequest(TffIntListItem(Items[anInx]).KeyAsInt);
|
|
if aRequest.ClientID = aClientID then begin
|
|
RequestFound := True; {!!.13}
|
|
{Begin !!.12}
|
|
{ If the request was something other than to check secure
|
|
communications (i.e., no password handling involved) then
|
|
post a message to the lost connection window. }
|
|
if aRequest.MsgID <> ffnmCheckSecureComms then
|
|
PostMessage(FLostConnWindow, ffm_LostConnection, aClientID, 0);
|
|
{End !!.12}
|
|
{ Mark the request as having lost its connection. }
|
|
aRequest.SetReply(aRequest.MsgID, fferrConnectionLost, nil, 0, 0);
|
|
{ Remove the request's entry from the list. }
|
|
DeleteAt(anInx);
|
|
aRequest.WakeUpThread;
|
|
break;
|
|
end; { if }
|
|
end; { for }
|
|
if not RequestFound then {!!.13}
|
|
PostMessage(FLostConnWindow, ffm_LostConnection, aClientID, 0);{!!.13}
|
|
finally
|
|
EndRead;
|
|
end;
|
|
{End !!.01}
|
|
end;
|
|
{--------}
|
|
procedure TffLegacyTransport.tpDatagramReceived(aSender : TObject;
|
|
const aName : TffNetName;
|
|
aData : PffByteArray;
|
|
aDataLen : Longint);
|
|
begin
|
|
tpLogReqMisc(format('Rcvd datagram from %s', [aName]));
|
|
end;
|
|
{--------}
|
|
function TffLegacyTransport.tpGetCodeStart(const aClientID : TffClientID) : integer;
|
|
begin
|
|
Result := FProtocol.GetCodeStart(aClientID);
|
|
end;
|
|
{--------}
|
|
procedure TffLegacyTransport.tpHandleAddClient(aMsg : PffDataMessage);
|
|
var
|
|
aReply : TffnmAttachServerRpy;
|
|
aClientID : TffClientID;
|
|
aVersionNumber : Longint;
|
|
errorCode : TffResult;
|
|
isSecure : boolean;
|
|
passwordHash : TffWord32;
|
|
begin
|
|
if assigned(FOnAddClient) then begin
|
|
FOnAddClient(Self, PffnmAttachServerReq(aMsg^.dmData)^.userID,
|
|
PffnmAttachServerReq(aMsg^.dmData)^.timeout,
|
|
PffnmAttachServerReq(aMsg^.dmData)^.clientVersion,
|
|
passwordHash, aClientID, errorCode, isSecure, aVersionNumber);
|
|
|
|
{ Build a reply. }
|
|
aReply.ClientID := aClientID;
|
|
aReply.VersionNumber := aVersionNumber;
|
|
{Begin !!.05}
|
|
FProtocol.ConnLock;
|
|
try
|
|
if isSecure then
|
|
aReply.Code := TffWord32(tpGetCodeStart(aMsg^.dmClientID)) xor passwordHash
|
|
else
|
|
aReply.Code := tpGetCodeStart(aMsg^.dmClientID);
|
|
aReply.IsSecure := isSecure;
|
|
aReply.LastMsgIntvl := ffc_LastMsgInterval;
|
|
aReply.KAIntvl := ffc_KeepAliveInterval;
|
|
aReply.KARetries := ffc_KeepAliveRetries;
|
|
|
|
{ Send the reply. }
|
|
Reply(aMsg^.dmMsg, errorCode, @aReply, sizeOf(TffnmAttachServerRpy));
|
|
|
|
{ Update the clientID maintained by the protocol. }
|
|
if errorCode = DBIERR_NONE then
|
|
FProtocol.UpdateClientID(aMsg^.dmClientID, aClientID);
|
|
finally
|
|
FProtocol.ConnUnlock;
|
|
end;
|
|
{End !!.05}
|
|
|
|
end else
|
|
{ No handler assigned. Send back an error. }
|
|
Reply(aMsg^.dmMsg, DBIERR_FF_NoAddHandler, nil, 0);
|
|
|
|
{ Free the message data. } {!!.01}
|
|
ltFreeMsg(aMsg); {!!.01}
|
|
end;
|
|
{--------}
|
|
procedure TffLegacyTransport.tpHandleNextRequest;
|
|
var
|
|
anItem : TffIntListItem;
|
|
aRequest : TffRequest;
|
|
Status : TffResult;
|
|
begin
|
|
|
|
{ Any messages in unsent request queue? Note that we don't care about
|
|
thread-safeness to check the count. We want to improve performance
|
|
by locking the queue only when necessary. If something slips into the
|
|
queue, we will run through this loop again very soon and pick it up
|
|
at that point. }
|
|
anItem := nil;
|
|
if FUnsentRequestQueue.Count > 0 then
|
|
{ Yes. Grab one. }
|
|
with FUnsentRequestQueue.BeginWrite do
|
|
try
|
|
anItem := TffIntListItem(FUnsentRequestQueue.Dequeue);
|
|
finally
|
|
EndWrite;
|
|
end;
|
|
|
|
if assigned(anItem) then begin
|
|
aRequest := TffRequest(anItem.KeyAsInt);
|
|
anItem.Free;
|
|
{ If this request has already timed out then ignore it. }
|
|
if aRequest.Aborted then
|
|
aRequest.Free
|
|
else begin
|
|
{ Otherwise send the request. }
|
|
Status := tpSendRequest(aRequest);
|
|
if (Status <> DBIERR_NONE) and
|
|
(aRequest.ReplyMode = ffrmReplyExpected) then begin
|
|
aRequest.ErrorCode := Status;
|
|
aRequest.WakeUpThread;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
end;
|
|
{--------}
|
|
procedure TffLegacyTransport.tpHandleRemoveClient(aMsg : PffDataMessage);
|
|
//var {Deleted !!.01}
|
|
// errorCode : TffResult; {Deleted !!.01}
|
|
begin
|
|
{Begin !!.01}
|
|
ltDoHangup(aMsg^.dmClientID);
|
|
// if assigned(FOnRemoveClient) then
|
|
// FOnRemoveClient(Self, aMsg^.dmClientID, errorCode)
|
|
// else
|
|
{ No handler assigned. Log an error. }
|
|
// lcLogFmt(('No RemoveClientHandler for transport %d', [GetName]));
|
|
{End !!.01}
|
|
{ Free the message data. } {!!.01}
|
|
ltFreeMsg(aMsg); {!!.01}
|
|
end;
|
|
{--------}
|
|
procedure TffLegacyTransport.tpInternalRequest(aRequest : TffRequest;
|
|
timeout : Longint;
|
|
aCookie : HWND);
|
|
var
|
|
anItem : TffIntListItem;
|
|
begin
|
|
aRequest.EventLog := FEventLog;
|
|
anItem := TffIntListItem.Create(Longint(aRequest));
|
|
anItem.MaintainLinks := False; {!!.01}
|
|
with FUnsentRequestQueue.BeginWrite do
|
|
try
|
|
Enqueue(anItem);
|
|
finally
|
|
EndWrite;
|
|
end;
|
|
|
|
if (aCookie <> 0) and IsWindow(aCookie) then
|
|
PostMessage(aCookie, 0, 0, 0);
|
|
|
|
{ Wait for the reply. If a timeout occurs, assume the request object
|
|
will be freed by the transport thread at some point. Timeout exceptions
|
|
are raised to the calling object. }
|
|
if timeout = 0 then
|
|
aRequest.WaitForReply(timeout)
|
|
else
|
|
aRequest.WaitForReply(timeout + ffcl_RequestLatencyAdjustment);
|
|
|
|
end;
|
|
{--------}
|
|
function TffLegacyTransport.tpMsgReceived(aSender : TObject;
|
|
clientID : TffClientID;
|
|
msgData : PffByteArray;
|
|
msgDataLen : Longint) : boolean;
|
|
var
|
|
MsgHeader : PffnmHeader absolute msgData;
|
|
begin
|
|
// Result := False; {!!.01}
|
|
case MsgHeader^.nmhMsgType of
|
|
ffmtRequest:
|
|
Result := tpRequestReceived(aSender, clientID, msgData, msgDataLen);
|
|
ffmtReply:
|
|
Result := tpReplyReceived(aSender, clientID, msgData, msgDataLen);
|
|
{Begin !!.01}
|
|
else begin
|
|
lcLogFmt(ffc_ErrMsgType,
|
|
[MsgHeader^.nmhMsgType, MsgHeader^.nmhClientID,
|
|
MsgHeader^.nmhMsgID]);
|
|
{ Pass it on to tpRequestReceived as this may just be the result of a
|
|
user entering a bad password. }
|
|
Result := tpRequestReceived(aSender, clientID, msgData, msgDataLen);
|
|
end;
|
|
end; { case }
|
|
{End !!.01}
|
|
end;
|
|
{--------}
|
|
procedure TffLegacyTransport.tpPrepareThread;
|
|
begin
|
|
if assigned(FTransportThread) then
|
|
FTransportThread.Free;
|
|
FTransportThread := TffLegacyTransportThread.Create(Self);
|
|
FTransportThread.FreeOnTerminate := False;
|
|
FTransportThread.OnTerminate := tpThreadTerminated;
|
|
end;
|
|
{--------}
|
|
procedure TffLegacyTransport.tpProcessCallback(const aProcessCookie : Longint);
|
|
var
|
|
conn : TffConnection;
|
|
msg : PffDataMessage;
|
|
begin
|
|
|
|
btStoreSelfInThreadvar;
|
|
|
|
{Begin !!.05}
|
|
msg := PffDataMessage(aProcessCookie);
|
|
conn := ProtocolCracker(FProtocol).cpGetConnection(msg^.dmClientID);
|
|
if conn <> nil then begin
|
|
conn.HangupLock;
|
|
try
|
|
{ Save off some data for when we reply. }
|
|
ffitvClientID := msg^.dmClientID;
|
|
ffitvRequestID := msg^.dmRequestID;
|
|
|
|
{ Is this a request to add a client? }
|
|
if (msg^.dmMsg = ffnmAttachServer) then begin
|
|
tpHandleAddClient(msg)
|
|
{ Remove a client? }
|
|
end else if (msg^.dmMsg = ffnmDetachServer) then begin
|
|
tpHandleRemoveClient(msg)
|
|
end else
|
|
{ None of the above. Call our Process method which will pass the message
|
|
onto the appropriate command handlers. }
|
|
Process(msg)
|
|
finally
|
|
conn.HangupUnlock;
|
|
end;
|
|
end;
|
|
{End !!.05}
|
|
end;
|
|
{--------}
|
|
procedure TffLegacyTransport.tpRemoteClientHangup(aSender : TObject;
|
|
aClientID : TffClientID);
|
|
//var {Deleted !!.01}
|
|
// errorCode : TffResult; {Deleted !!.01}
|
|
begin
|
|
{ As a just in case, make sure the client is removed. }
|
|
{Begin !!.01}
|
|
ltDoHangup(aClientID);
|
|
// if assigned(FOnRemoveClient) then
|
|
// FOnRemoveClient(Self, aClientID, errorCode);
|
|
{End !!.01}
|
|
end;
|
|
{--------}
|
|
function TffLegacyTransport.tpReplyReceived(aSender : TObject;
|
|
clientID : TffClientID;
|
|
replyData : PffByteArray;
|
|
replyDataLen : Longint): boolean;
|
|
var
|
|
msgHeader : PffnmHeader absolute replyData;
|
|
anItem : TffIntListItem;
|
|
aRequest : TffRequest;
|
|
begin
|
|
Result := True;
|
|
|
|
{ Find the request. }
|
|
with FWaitingForReplyList.BeginRead do
|
|
try
|
|
anItem := TffIntListItem
|
|
(FWaitingForReplyList
|
|
[FWaitingForReplyList.Index(msgHeader^.nmhRequestID)]);
|
|
finally
|
|
EndRead;
|
|
end;
|
|
|
|
{ Did we find the request? If so then set its reply data.
|
|
|
|
If we did not find the request then the requesting thread timed out
|
|
and we can just toss the reply into the bitbucket. }
|
|
if assigned(anItem) then begin
|
|
aRequest := TffRequest(anItem.keyAsInt);
|
|
|
|
with msgHeader^ do
|
|
if msgHeader^.nmhFirstPart then
|
|
aRequest.SetReply(nmhMsgID, nmhErrorCode, @nmhData, nmhTotalSize,
|
|
replyDataLen - ffc_NetMsgHeaderSize)
|
|
else
|
|
aRequest.AddToReply(@nmhData, replyDataLen - ffc_NetMsgHeaderSize);
|
|
|
|
{ If this is the last part of the message then remove the request from
|
|
the waiting list. }
|
|
if msgHeader^.nmhLastPart then begin
|
|
with FWaitingForReplyList.BeginWrite do
|
|
try
|
|
Delete(Longint(msgHeader^.nmhRequestID));
|
|
finally
|
|
EndWrite;
|
|
end;
|
|
{ If the request has been aborted then get rid of it otherwise
|
|
wake up the requesting thread. }
|
|
if aRequest.Aborted then
|
|
aRequest.Free
|
|
else begin
|
|
tpLogReply(aRequest);
|
|
aRequest.WakeUpThread;
|
|
end;
|
|
end;
|
|
|
|
end else begin
|
|
lcLogFmt('Could not find Request %d, msgID %d',
|
|
[msgHeader^.nmhRequestID, msgHeader^.nmhMsgID]);
|
|
end;
|
|
|
|
end;
|
|
{--------}
|
|
function TffLegacyTransport.tpRequestReceived(aSender : TObject;
|
|
clientID : TffClientID;
|
|
requestData : PffByteArray;
|
|
requestDataLen : Longint) : boolean;
|
|
var
|
|
MsgHeader : PffnmHeader absolute requestData;
|
|
MsgNode : PffDataMessageNode;
|
|
begin
|
|
Result := True;
|
|
|
|
with MsgHeader^ do begin
|
|
|
|
{ Verify the client id in the message is correct. If not then either
|
|
we have a fake client using the wrong encryption or something else is
|
|
goofed up. Hangup. }
|
|
if (nmhMsgID <> ffnmAttachServer) and
|
|
(clientID <> nmhClientID) then begin
|
|
|
|
if FLogEnabled and assigned(FEventLog) and
|
|
(fftpLogErrors in FLogOptions) then
|
|
FEventLog.WriteStrings(['Hanging up due to bad client password',
|
|
Format(' ClientID (actual) %d', [clientID]),
|
|
Format(' ClientID (msg) %d', [nmhClientID]),
|
|
Format(' MsgID %d', [nmhMsgID])]);
|
|
|
|
FProtocol.HangUpByClientID(clientID);
|
|
Result := false;
|
|
Exit;
|
|
end;
|
|
|
|
if FLogEnabled and assigned(FEventLog) and
|
|
(fftpLogRequests in FLogOptions) then
|
|
tpLogReq2(ffc_Request, nmhRequestID, clientID, nmhMsgID, @nmhData,
|
|
requestDataLen - ffc_NetMsgHeaderSize, nmhTimeout);
|
|
|
|
with FMsgQueue.BeginWrite do
|
|
try
|
|
if nmhFirstPart then
|
|
MsgNode := Append(nmhMsgID,
|
|
clientID,
|
|
nmhRequestID,
|
|
nmhTimeout,
|
|
0,
|
|
@nmhData,
|
|
requestDataLen - ffc_NetMsgHeaderSize,
|
|
nmhTotalSize)
|
|
else
|
|
MsgNode := AddToData(nmhMsgID,
|
|
clientID,
|
|
nmhRequestID,
|
|
@nmhData,
|
|
requestDataLen - ffc_NetMsgHeaderSize);
|
|
finally
|
|
EndWrite;
|
|
end;
|
|
|
|
{ Is this the last part of the message? }
|
|
if assigned(MsgNode) then begin
|
|
{ Yes. Do we have a thead pool? }
|
|
if assigned(FThreadPool) then
|
|
{ Yes. Pass this request off to a worker thread. }
|
|
FThreadPool.ProcessThreaded(tpProcessCallback, Longint(MsgNode^.dmnMsg))
|
|
else
|
|
{ No. Handle this ourselves. }
|
|
tpProcessCallback(Longint(MsgNode^.dmnMsg));
|
|
|
|
{ Get rid of the request on the message queue. }
|
|
with FMsgQueue.BeginWrite do
|
|
try
|
|
Remove(MsgNode, false);
|
|
finally
|
|
EndWrite;
|
|
end;
|
|
end;
|
|
end; { with }
|
|
end;
|
|
{--------}
|
|
function TffLegacyTransport.tpSendReply(msgID : Longint;
|
|
clientID : TffClientID;
|
|
requestID : Longint;
|
|
errorCode : TffResult;
|
|
replyData : pointer;
|
|
replyDataLen : Longint) : TffResult;
|
|
var
|
|
BytesToGo : Longint;
|
|
BytesToSend : Longint;
|
|
FirstMsg : boolean;
|
|
LastMsg : boolean;
|
|
StartOffset : Longint;
|
|
SendBuffer : PffnmHeader;
|
|
begin
|
|
|
|
try
|
|
|
|
FFGetMem(SendBuffer, FProtocol.MaxNetMsgSize);
|
|
|
|
try
|
|
{ Set up the message header. }
|
|
with SendBuffer^ do begin
|
|
nmhMsgType := ffmtReply;
|
|
nmhMsgID := msgID;
|
|
nmhTotalSize := replyDataLen;
|
|
nmhClientID := clientID;
|
|
nmhRequestID := requestID;
|
|
nmhErrorCode := errorCode;
|
|
nmhTimeout := 0;
|
|
end;
|
|
|
|
StartOffset := 0;
|
|
BytesToGo := replyDataLen;
|
|
FirstMsg := true;
|
|
|
|
{ Send data in reasonably-sized chunks }
|
|
repeat
|
|
{ Calculate the size of the data to send in this message packet. }
|
|
BytesToSend := FFMinL(BytesToGo,
|
|
FProtocol.MaxNetMsgSize - ffc_NetMsgHeaderSize);
|
|
LastMsg := (BytesToSend = BytesToGo);
|
|
with SendBuffer^ do begin
|
|
nmhMsgLen := ffc_NetMsgHeaderSize + BytesToSend;
|
|
nmhFirstPart := FirstMsg;
|
|
nmhLastPart := LastMsg;
|
|
end;
|
|
|
|
{ Copy the data into the send buffer. }
|
|
if (BytesToSend > 0) then
|
|
Move(PffBLOBArray(replyData)^[StartOffset],
|
|
SendBuffer^.nmhData, BytesToSend);
|
|
|
|
{ Send the packet. }
|
|
Result := FProtocol.SendMsg(clientID, PffByteArray(SendBuffer),
|
|
SendBuffer^.nmhMsgLen, True); {!!.06}
|
|
|
|
{ Do we need to get an acknowledgement? }
|
|
if not LastMsg then begin
|
|
{ Update bytes sent, etc. }
|
|
dec(BytesToGo, BytesToSend);
|
|
inc(StartOffset, BytesToSend);
|
|
FirstMsg := false;
|
|
end;
|
|
|
|
until LastMsg or (Result <> DBIERR_NONE);
|
|
{Moved !!.06}
|
|
{Begin !!.10}
|
|
if Result <> DBIERR_NONE then
|
|
lcLogFmt(ffc_SendErr,
|
|
[Result, 'tpSendReply', -1, clientID, msgID, replyDataLen, 0])
|
|
else if FLogEnabled and assigned(FEventLog) and
|
|
{End !!.10}
|
|
(fftpLogReplies in FLogOptions) then
|
|
tpLogReply2(requestID, clientID, msgID, replyDataLen, errorCode);
|
|
finally
|
|
FFFreeMem(SendBuffer, FProtocol.MaxNetMsgSize);
|
|
end;
|
|
except
|
|
on E:EffWinsockException do begin
|
|
Result := fferrTransportFail;
|
|
lcLogFmt('Transport failure %d: %s', [E.ErrorCode, E.Message]);
|
|
end;
|
|
on E:EffException do
|
|
Result := E.ErrorCode;
|
|
end;
|
|
end;
|
|
{--------}
|
|
function TffLegacyTransport.tpSendRequest(aRequest : TffRequest) : TffResult;
|
|
var
|
|
aClientID : TffClientID;
|
|
anItem : TffIntListItem;
|
|
BytesToSend : Longint;
|
|
FirstMsg : boolean;
|
|
LastMsg : boolean;
|
|
CallRpy : PffnmCallServerRpy;
|
|
const
|
|
logPrefixArray : array[TffReplyModeType] of string = (ffc_Request,
|
|
ffc_Post,
|
|
ffc_PostWait);
|
|
begin
|
|
|
|
Result := DBIERR_NONE;
|
|
anItem := nil;
|
|
|
|
try
|
|
|
|
tpLogReq(aRequest, logPrefixArray[aRequest.ReplyMode]);
|
|
|
|
{ Is this a "call server" request or a regular request? }
|
|
if aRequest.MsgID = ffnmCallServer then begin
|
|
{Begin !!.05}
|
|
tpLogReqMisc(Format(ffc_ReqLogString,
|
|
[ffc_Request, Longint(aRequest), aRequest.ClientID,
|
|
aRequest.MsgID, aRequest.RequestDataLen,
|
|
aRequest.Timeout]));
|
|
{End !!.05}
|
|
aRequest.ErrorCode :=
|
|
FProtocol.Call(PffnmCallServerReq(aRequest.RequestData).ServerName,
|
|
aClientID, aRequest.Timeout);
|
|
FFGetMem(CallRpy, SizeOf(TffnmCallServerRpy));
|
|
CallRpy^.ClientID := aClientID;
|
|
aRequest.ReplyData := CallRpy;
|
|
aRequest.ReplyDataLen := SizeOf(TffnmCallServerRpy);
|
|
aRequest.ReplyMsgID := ffnmCallServer;
|
|
{Begin !!.05}
|
|
if FLogEnabled and (fftpLogReplies in FLogOptions) and
|
|
(FEventLog <> nil) then
|
|
with aRequest do
|
|
FEventLog.WriteString(Format(ffc_ReplyLogString,
|
|
[Longint(aRequest), ClientID,
|
|
ReplyMsgID, ReplyDataLen, ErrorCode]));
|
|
{End !!.05}
|
|
aRequest.WakeUpThread;
|
|
anItem.Free;
|
|
exit;
|
|
end;
|
|
|
|
{ Set up the message header. }
|
|
with FSendBuffer^ do begin
|
|
nmhMsgType := ffmtRequest;
|
|
nmhMsgID := aRequest.MsgID;
|
|
nmhTotalSize := aRequest.RequestDataLen;
|
|
nmhClientID := aRequest.ClientID;
|
|
nmhRequestID := Longint(aRequest);
|
|
nmhErrorCode := 0;
|
|
nmhTimeout := aRequest.Timeout;
|
|
end;
|
|
|
|
FirstMsg := (aRequest.StartOffset = 0);
|
|
|
|
|
|
{ Obtain exclusive write access. This is required because a reply
|
|
may be received from the server before an iteration of this repeat..until
|
|
block completes. In that situation, we want to make sure this method
|
|
finishes before the TffRequest is freed.
|
|
|
|
The corresponding call to TffRequest.Lock is in the TffRequest.Destroy
|
|
method. }
|
|
aRequest.Lock;
|
|
|
|
try
|
|
|
|
{ Send data in reasonably-sized chunks }
|
|
repeat
|
|
|
|
{ Calculate the size of the data to send in this message packet. }
|
|
BytesToSend := FFMinL(aRequest.BytesToGo,
|
|
FProtocol.MaxNetMsgSize - ffc_NetMsgHeaderSize);
|
|
LastMsg := (BytesToSend = aRequest.BytesToGo);
|
|
with FSendBuffer^ do begin
|
|
nmhMsgLen := ffc_NetMsgHeaderSize + BytesToSend;
|
|
nmhFirstPart := FirstMsg;
|
|
nmhLastPart := LastMsg;
|
|
end;
|
|
|
|
{ Copy the data into the send buffer. }
|
|
if (BytesToSend > 0) then
|
|
Move(PffBLOBArray(aRequest.RequestData)^[aRequest.StartOffset],
|
|
FSendBuffer^.nmhData, BytesToSend);
|
|
|
|
{ Update bytes sent, etc. }
|
|
aRequest.BytesToGo := aRequest.BytesToGo - BytesToSend;
|
|
aRequest.StartOffset := aRequest.StartOffset + BytesToSend;
|
|
|
|
{ If this is the first message and the requesting thread must wait for a
|
|
reply, add the request to the Waiting For Reply list before we actually
|
|
send the message to the server. We do this to avoid the situation where
|
|
the reply is received before we actually get the request into the
|
|
Waiting For Reply list.
|
|
|
|
The request will sit in the Waiting For Reply list until the entire
|
|
reply is received. }
|
|
if FirstMsg and (aRequest.ReplyMode = ffrmReplyExpected) then
|
|
with FWaitingForReplyList.BeginWrite do
|
|
try
|
|
anItem := TffIntListItem.Create(Longint(aRequest));
|
|
Insert(anItem);
|
|
finally
|
|
EndWrite;
|
|
end;
|
|
|
|
{ Send the packet. }
|
|
Result := FProtocol.SendMsg(aRequest.ClientID, PffByteArray(FSendBuffer),
|
|
FSendBuffer^.nmhMsgLen, True); {!!.06}
|
|
|
|
{ If the send failed & we were expecting a reply, take the request out
|
|
of the Waiting For Reply list because no reply is forthcoming. }
|
|
if (Result <> DBIERR_NONE) and
|
|
(aRequest.ReplyMode = ffrmReplyExpected) then begin {!!.03}
|
|
aRequest.ReplyMsgID := aRequest.MsgID; {!!.03}
|
|
with FWaitingForReplyList.BeginWrite do
|
|
try
|
|
Delete(Longint(aRequest));
|
|
finally
|
|
EndWrite;
|
|
end;
|
|
end; {!!.03}
|
|
|
|
FirstMsg := False; {!!.01}
|
|
|
|
until LastMsg or (Result <> DBIERR_NONE);
|
|
|
|
if Result <> DBIERR_NONE then
|
|
lcLogFmt(ffc_SendErr,
|
|
[Result, 'tpSendRequest', -1, aRequest.ClientID,
|
|
aRequest.MsgID, aRequest.RequestDataLen, aRequest.Timeout]);
|
|
|
|
{ Is the requesting thread waiting for the request to be sent to the
|
|
server but not wanting a reply? }
|
|
if aRequest.ReplyMode = ffrmNoReplyWaitUntilSent then begin
|
|
{ Yes. Was the request aborted by the requesting thread
|
|
(i.e, timeout)? }
|
|
if aRequest.Aborted then begin
|
|
{ Yes. Free the request. }
|
|
aRequest.Unlock;
|
|
aRequest.Free;
|
|
aRequest := nil;
|
|
end else
|
|
{ No. Signal the requesting thread. }
|
|
aRequest.WakeUpThread;
|
|
end;
|
|
|
|
finally
|
|
if assigned(aRequest) then begin
|
|
aRequest.Unlock;
|
|
if aRequest.ReplyMode = ffrmNoReplyExpected then
|
|
aRequest.Free;
|
|
end;
|
|
end;
|
|
except
|
|
on E:Exception do begin
|
|
{ Free the list item. }
|
|
if assigned(anItem) then
|
|
anItem.Free;
|
|
|
|
{ Handle the exception. }
|
|
if E is EffWinsockException then begin
|
|
Result := fferrTransportFail;
|
|
lcLogFmt('Transport failure %d: %s',
|
|
[EffWinsockException(E).ErrorCode, E.Message]);
|
|
end
|
|
else if E is EffException then begin
|
|
Result := EffException(E).ErrorCode;
|
|
lcLogFmt('tpSendRequest exception %d: %s',
|
|
[EffException(E).ErrorCode, E.Message]);
|
|
end
|
|
else begin
|
|
Result := fferrTransportFail;
|
|
lcLogFmt('tpSendRequest general exception %s:', [E.Message]);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
end;
|
|
{--------}
|
|
procedure TffLegacyTransport.tpShutdownProtocol;
|
|
begin
|
|
if FLogEnabled and assigned(FEventLog) and
|
|
((fftpLogRequests in FLogOptions) or
|
|
(fftpLogReplies in FLogOptions)) then
|
|
tpLogReqMisc(format('Transport thread (%s) shut down.', [GetName]));
|
|
FProtocol.Shutdown;
|
|
end;
|
|
{--------}
|
|
procedure TffLegacyTransport.tpStartProtocol;
|
|
begin
|
|
FProtocol.Startup;
|
|
|
|
{ If we are to listen for broadcasts then set up to receive datagrams. }
|
|
//if (FMode = fftmListen) and FRespondToBroadcasts then begin {!!.05 - Start}
|
|
// FProtocol.ReceiveDatagram;
|
|
// FProtocol.Listen;
|
|
//end; }
|
|
if (FMode = fftmListen) then begin
|
|
FProtocol.Listen;
|
|
if (FRespondToBroadcasts) then
|
|
FProtocol.ReceiveDatagram;
|
|
end; {!!.05 - End}
|
|
end;
|
|
{--------}
|
|
procedure TffLegacyTransport.tpThreadTerminated(Sender : TObject);
|
|
begin
|
|
if TffLegacyTransportThread(Sender).UnexpectedTermination then begin
|
|
{ The thread has shutdown prematurely. Log the event and restart
|
|
the thread. }
|
|
if assigned(FProtocol) then
|
|
lcLogFmt('Transport thread (%s) prematurely stopped.', [GetName]);
|
|
tpPrepareThread;
|
|
FTransportThread.Resume;
|
|
end;
|
|
end;
|
|
{--------}
|
|
procedure TffLegacyTransport.Work;
|
|
begin
|
|
|
|
{ Legacy transports can both send and receive messages
|
|
(i.e., bi-directional). }
|
|
|
|
{ Give the protocol a chance to receive requests. }
|
|
FProtocol.Breathe;
|
|
|
|
{ Give the protocol a chance to send a request. }
|
|
tpHandleNextRequest;
|
|
|
|
end;
|
|
{====================================================================}
|
|
|
|
{===TffLegacyTransportThread=========================================}
|
|
constructor TffLegacyTransportThread.Create(aTransport : TffLegacyTransport);
|
|
begin
|
|
inherited Create(True);
|
|
FTransport := aTransport;
|
|
FUnexpectedTermination := false;
|
|
end;
|
|
{--------}
|
|
procedure TffLegacyTransportThread.Execute;
|
|
begin
|
|
try
|
|
FTransport.tpStartProtocol;
|
|
repeat
|
|
try
|
|
FTransport.Work;
|
|
except
|
|
on E:Exception do
|
|
FTransport.lcLog
|
|
(format('Transport thread (%s) error: %s',
|
|
[FTransport.GetName, E.message]));
|
|
end;
|
|
until Terminated;
|
|
FTransport.tpShutdownProtocol;
|
|
except
|
|
on E:Exception do begin
|
|
{ Signal the primary thread so that it can see our failure to start. }
|
|
FTransport.FProtocol.StartedEvent.SignalEvent;
|
|
FTransport.lcLog
|
|
(format('Transport thread startup (%s) error: %s',
|
|
[FTransport.GetName, E.message]));
|
|
end;
|
|
end;
|
|
end;
|
|
{====================================================================}
|
|
end.
|