{ ************************************************************** Package: XWB - Kernel RPCBroker Date Created: Sept 18, 1997 (Version 1.1) Site Name: Oakland, OI Field Office, Dept of Veteran Affairs Developers: Danila Manapsal, Don Craven, Joel Ivey Description: Contains TRPCBroker and related components. Current Release: Version 1.1 Patch 47 (Jun. 17, 2008)) *************************************************************** } {* Adding use of SSH tunneling as command line option (or property) It appears that tunneling with Attachmate Reflection will be used within the VA. However, code for the use of Plink.exe for ssh tunneling is also provided to permit secure connections for those using VistA outside of the VA. for SSH Tunneling using Attachmate Reflection SSH set as commandline option or as a property (set to Attachmate Reflection) will also be set to true if either of the following command line parameters are set. SSHPort=portnumber to specify a particular port number if not specified, it will use the port number for the remote server. SSHUser=username for remote server if not specified, user will be prompted for SSH tunneling with Plink.exe UsePlink set as command line option or as a property (set to Plink). SSHPort=portnumber *} {************************************************** This is the hierarchy of things: TRPCBroker contains TParams, which contains array of TParamRecord each of which contains TMult v1.1*4 Silent Login changes (DCM) 10/22/98 1.1*6 Polling to support terminating arphaned server jobs. (P6) == DPC 4/99 1.1*8 Check for Multi-Division users. (P8) - REM 7/13/99 1.1*13 More silent login code; deleted obsolete lines (DCM) 9/10/99 // p13 LAST UPDATED: 5/24/2001 // p13 JLI 1.1*31 Added new read only property BrokerVersion to TRPCBroker which should contain the version number for the RPCBroker (or SharedRPCBroker) in use. **************************************************} unit Trpcb; interface {$I IISBase.inc} uses {Delphi standard} Classes, Controls, Dialogs, {DsgnIntf,} Forms, Graphics, Messages, SysUtils, WinProcs, WinTypes, Windows, extctrls, {P6} {VA} XWBut1, {RpcbEdtr,} MFunStr, Hash, //; //P14 -- pack split ComObj, ActiveX, OleCtrls, VERGENCECONTEXTORLib_TLB; const NoMore: boolean = False; MIN_RPCTIMELIMIT: integer = 30; CURRENT_RPC_VERSION: String = 'XWB*1.1*50'; type TParamType = (literal, reference, list, global, empty, stream, undefined); // 030107 JLI Modified for new message protocol //P14 -- pack split -- Types moved from RpcbEdtr.pas. TAccessVerifyCodes = string[255]; //to use TAccessVerifyCodesProperty editor use this type TRemoteProc = string[100]; //to use TRemoteProcProperty editor use this type TServer = string[255]; //to use TServerProperty editor use this type TRpcVersion = string[255]; //to use TRpcVersionProperty editor use this type TRPCBroker = class; TVistaLogin = class; // p13 TLoginMode = (lmAVCodes, lmAppHandle, lmNTToken); TShowErrorMsgs = (semRaise, semQuiet); // p13 TOnLoginFailure = procedure (VistaLogin: TVistaLogin) of object; //p13 TOnRPCBFailure = procedure (RPCBroker: TRPCBroker) of object; //p13 TOnPulseError = procedure(RPCBroker: TRPCBroker; ErrorText: String) of object; // TOnRPCCall = procedure (RPCBroker: TRPCBroker; SetNum: Integer; RemoteProcedure: TRemoteProc; CurrentContext: String; RpcVersion: TRpcVersion; Param: TParams; RPCTimeLimit: Integer; Results, Sec, App: PChar; DateTime: TDateTime) of object; TSecure = (secureNone, secureAttachmate, securePlink); {------ EBrokerError ------} EBrokerError = class(Exception) public Action: string; Code: integer; Mnemonic: string; end; {------ TString ------} TString = class(TObject) Str: string; end; {------ TMult ------} {:This component defines the multiple field of a parameter. The multiple field is used to pass string-subscripted array of data in a parameter.} TMult = class(TComponent) private FMultiple: TStringList; procedure ClearAll; function GetCount: Word; function GetFirst: string; function GetLast: string; function GetFMultiple(Index: string): string; function GetSorted: boolean; procedure SetFMultiple(Index: string; value: string); procedure SetSorted(Value: boolean); protected public constructor Create(AOwner: TComponent); override; {1.1T8} destructor Destroy; override; procedure Assign(Source: TPersistent); override; function Order(const StartSubscript: string; Direction: integer): string; function Position(const Subscript: string): longint; function Subscript(const Position: longint): string; property Count: Word read GetCount; property First: string read GetFirst; property Last: string read GetLast; property MultArray[I: string]: string read GetFMultiple write SetFMultiple; default; property Sorted: boolean read GetSorted write SetSorted; end; {------ TParamRecord ------} {:This component defines all the fields that comprise a parameter.} TParamRecord = class(TComponent) private FMult: TMult; FValue: string; FPType: TParamType; protected public constructor Create(AOwner: TComponent); override; destructor Destroy; override; property Value: string read FValue write FValue; property PType: TParamType read FPType write FPType; property Mult: TMult read FMult write FMult; end; {------ TParams ------} {:This component is really a collection of parameters. Simple inclusion of this component in the Broker component provides access to all of the parameters that may be needed when calling a remote procedure.} TParams = class(TComponent) private FParameters: TList; function GetCount: Word; function GetParameter(Index: integer): TParamRecord; procedure SetParameter(Index: integer; Parameter: TParamRecord); public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Assign(Source: TPersistent); override; procedure Clear; property Count: Word read GetCount; property ParamArray[I: integer]: TParamRecord read GetParameter write SetParameter; default; end; {------ TVistaLogin ------} //p13 TVistaLogin = class(TPersistent) private FLogInHandle : string; FNTToken : string; FAccessCode : string; FVerifyCode : string; FDivision : string; FMode: TLoginMode; FDivLst: TStrings; FOnFailedLogin: TOnLoginFailure; FMultiDivision : boolean; FDUZ: string; FErrorText : string; FPromptDiv : boolean; FIsProductionAccount: Boolean; FDomainName: string; procedure SetAccessCode(const Value: String); procedure SetLogInHandle(const Value: String); procedure SetNTToken(const Value: String); procedure SetVerifyCode(const Value: String); procedure SetDivision(const Value: String); //procedure SetWorkstationIPAddress(const Value: String); procedure SetMode(const Value: TLoginMode); procedure SetMultiDivision(Value: Boolean); procedure SetDuz(const Value: string); procedure SetErrorText(const Value: string); procedure SetPromptDiv(const Value: boolean); protected procedure FailedLogin(Sender: TObject); dynamic; public constructor Create(AOwner: TComponent); virtual; destructor Destroy; override; property LogInHandle: String read FLogInHandle write SetLogInHandle; //for use by a 2ndary DHCP login OR ESSO login property NTToken: String read FNTToken write SetNTToken; property DivList: TStrings read FDivLst; property OnFailedLogin: TOnLoginFailure read FOnFailedLogin write FOnFailedLogin; property MultiDivision: Boolean read FMultiDivision write SetMultiDivision; property DUZ: string read FDUZ write SetDuz; property ErrorText: string read FErrorText write SetErrorText; property IsProductionAccount: Boolean read FIsProductionAccount write FIsProductionAccount; property DomainName: string read FDomainName write FDomainName; published property AccessCode: String read FAccessCode write SetAccessCode; property VerifyCode: String read FVerifyCode write SetVerifyCode; property Mode: TLoginMode read FMode write SetMode; property Division: String read FDivision write SetDivision; property PromptDivision: boolean read FPromptDiv write SetPromptDiv; end; {------ TVistaUser ------} //holds 'generic' user attributes {p13} TVistaUser = class(TObject) private FDUZ: string; FName: string; FStandardName: string; FDivision: String; FVerifyCodeChngd: Boolean; FTitle: string; FServiceSection: string; FLanguage: string; FDtime: string; FVpid: String; procedure SetDivision(const Value: String); procedure SetDUZ(const Value: String); procedure SetName(const Value: String); procedure SetVerifyCodeChngd(const Value: Boolean); procedure SetStandardName(const Value: String); procedure SetTitle(const Value: string); procedure SetDTime(const Value: string); procedure SetLanguage(const Value: string); procedure SetServiceSection(const Value: string); public property DUZ: String read FDUZ write SetDUZ; property Name: String read FName write SetName; property StandardName: String read FStandardName write SetStandardName; property Division: String read FDivision write SetDivision; property VerifyCodeChngd: Boolean read FVerifyCodeChngd write SetVerifyCodeChngd; property Title: string read FTitle write SetTitle; property ServiceSection: string read FServiceSection write SetServiceSection; property Language: string read FLanguage write SetLanguage; property DTime: string read FDTime write SetDTime; property Vpid: string read FVpid write FVpid; end; {------ TRPCBroker ------} {:This component, when placed on a form, allows design-time and run-time connection to the server by simply toggling the Connected property. Once connected you can access server data.} TRPCBroker = class(TComponent) //private private protected FBrokerVersion: String; FIsBackwardCompatibleConnection: Boolean; FIsNewStyleConnection: Boolean; FOldConnectionOnly: Boolean; FAccessVerifyCodes: TAccessVerifyCodes; FClearParameters: Boolean; FClearResults: Boolean; FConnected: Boolean; FConnecting: Boolean; FCurrentContext: String; FDebugMode: Boolean; FListenerPort: integer; FParams: TParams; FResults: TStrings; FRemoteProcedure: TRemoteProc; FRpcVersion: TRpcVersion; FServer: TServer; FSocket: integer; FRPCTimeLimit : integer; //for adjusting client RPC duration timeouts FPulse : TTimer; //P6 FKernelLogIn : Boolean; //p13 FLogIn: TVistaLogIn; //p13 FUser: TVistaUser; //p13 FOnRPCBFailure: TOnRPCBFailure; FShowErrorMsgs: TShowErrorMsgs; FRPCBError: String; FOnPulseError: TOnPulseError; FSecurityPhrase: String; // BSE JLI 060130 // Added from CCOWRPCBroker FCCOWLogonIDName: String; FCCOWLogonIDValue: String; FCCOWLogonName: String; FCCOWLogonNameValue: String; FContextor: TContextorControl; //CCOW FCCOWtoken: string; //CCOW FVistaDomain: String; FCCOWLogonVpid: String; FCCOWLogonVpidValue: String; FWasUserDefined: Boolean; // end of values from CCOWRPCBroker // values for handling SSH tunnels FUseSecureConnection: TSecure; FSSHPort: String; FSSHUser: String; FSSHpw: String; FSSHhide: Boolean; FLastServer: String; FLastPort: Integer; // end SSH tunnel values function GetCCOWHandle(ConnectedBroker: TRPCBroker): string; procedure CCOWsetUser(Uname, token, Domain, Vpid: string; Contextor: TContextorControl); function GetCCOWduz( Contextor: TContextorControl): string; protected procedure SetClearParameters(Value: Boolean); virtual; procedure SetClearResults(Value: Boolean); virtual; procedure SetConnected(Value: Boolean); virtual; procedure SetResults(Value: TStrings); virtual; procedure SetServer(Value: TServer); virtual; procedure SetRPCTimeLimit(Value: integer); virtual; //Screen changes to timeout. procedure DoPulseOnTimer(Sender: TObject); virtual; //p6 procedure SetKernelLogIn(const Value: Boolean); virtual; // procedure SetLogIn(const Value: TVistaLogIn); virtual; procedure SetUser(const Value: TVistaUser); virtual; procedure CheckSSH; function getSSHPassWord: string; function getSSHUsername: string; function StartSecureConnection(var PseudoServer, PseudoPort: String): Boolean; public XWBWinsock: TObject; // 060919 added for multiple brokers with both old and new Prefix: String; property AccessVerifyCodes: TAccessVerifyCodes read FAccessVerifyCodes write FAccessVerifyCodes; property Param: TParams read FParams write FParams; property Socket: integer read FSocket; property RPCTimeLimit : integer read FRPCTimeLimit write SetRPCTimeLimit; destructor Destroy; override; procedure Call; virtual; procedure Loaded; override; procedure lstCall(OutputBuffer: TStrings); virtual; function pchCall: PChar; virtual; function strCall: string; virtual; function CreateContext(strContext: string): boolean; virtual; property CurrentContext: String read FCurrentContext; property User: TVistaUser read FUser write SetUser; property OnRPCBFailure: TOnRPCBFailure read FOnRPCBFailure write FOnRPCBFailure; property RPCBError: String read FRPCBError write FRPCBError; property OnPulseError: TOnPulseError read FOnPulseError write FOnPulseError; property BrokerVersion: String read FBrokerVersion; property IsNewStyleConnection: Boolean read FIsNewStyleConnection; property SecurityPhrase: String read FSecurityPhrase write FSecurityPhrase; // BSE JLI 060130 // brought in from CCOWRPCBroker function GetCCOWtoken(Contextor: TContextorControl): string; function IsUserCleared: Boolean; function WasUserDefined: Boolean; function IsUserContextPending(aContextItemCollection: IContextItemCollection): Boolean; property Contextor: TContextorControl read Fcontextor write FContextor; //CCOW property CCOWLogonIDName: String read FCCOWLogonIDName; property CCOWLogonIDValue: String read FCCOWLogonIDValue; property CCOWLogonName: String read FCCOWLogonName; property CCOWLogonNameValue: String read FCCOWLogonNameValue; property CCOWLogonVpid: String read FCCOWLogonVpid; property CCOWLogonVpidValue: String read FCCOWLogonVpidValue; // added for secure connection via SSH property SSHport: String read FSSHPort write FSSHPort; property SSHUser: String read FSSHUser write FSSHUser; property SSHpw: String read FSSHpw write FSSHpw; published constructor Create(AOwner: TComponent); override; property ClearParameters: boolean read FClearParameters write SetClearParameters; property ClearResults: boolean read FClearResults write SetClearResults; property Connected: boolean read FConnected write SetConnected; property DebugMode: boolean read FDebugMode write FDebugMode default False; property ListenerPort: integer read FListenerPort write FListenerPort; property Results: TStrings read FResults write SetResults; property RemoteProcedure: TRemoteProc read FRemoteProcedure write FRemoteProcedure; property RpcVersion: TRpcVersion read FRpcVersion write FRpcVersion; property Server: TServer read FServer write SetServer; property KernelLogIn: Boolean read FKernelLogIn write SetKernelLogIn; property ShowErrorMsgs: TShowErrorMsgs read FShowErrorMsgs write FShowErrorMsgs default semRaise; property LogIn: TVistaLogIn read FLogIn write FLogin; // SetLogIn; property IsBackwardCompatibleConnection: Boolean read FIsBackwardCompatibleConnection write FIsBackwardCompatibleConnection default True; property OldConnectionOnly: Boolean read FOldConnectionOnly write FOldConnectionOnly; // 080624 added property to permit app to set secure connection if desired // property UseSecureConnection: Boolean read FUseSecureConnection write // FUseSecureConnection; property UseSecureConnection: TSecure read FUseSecureConnection write FUSeSecureConnection; property SSHHide: Boolean read FSSHHide write FSSHHide; end; {procedure Register;} //P14 --pack split procedure StoreConnection(Broker: TRPCBroker); function RemoveConnection(Broker: TRPCBroker): boolean; function DisconnectAll(Server: string; ListenerPort: integer): boolean; function ExistingSocket(Broker: TRPCBroker): integer; procedure AuthenticateUser(ConnectingBroker: TRPCBroker); procedure GetBrokerInfo(ConnectedBroker : TRPCBroker); //P6 function NoSignOnNeeded : Boolean; function ProcessExecute(Command: string; cShow: Word): Integer; function GetAppHandle(ConnectedBroker : TRPCBroker): String; function ShowApplicationAndFocusOK(anApplication: TApplication): boolean; var DebugData: string; BrokerConnections: TStringList; {this list stores all connections by socket number} BrokerAllConnections: TStringList; {this list stores all connections to all of the servers, by an application. It's used in DisconnectAll} // 080618 following 2 variables added to handle closing of command box for SSH CommandBoxProcessHandle: THandle; CommandBoxThreadHandle: THandle; implementation uses Loginfrm, RpcbErr, SelDiv{p8}, RpcSLogin{p13}, fRPCBErrMsg, Wsockc, CCOW_const, fPlinkpw, fSSHUsername; var CCOWToken: String; Domain: String; PassCode1: String; PassCode2: String; const DEFAULT_PULSE : integer = 81000; //P6 default = 45% of 3 minutes. MINIMUM_TIMEOUT : integer = 14; //P6 shortest allowable timeout in secs. PULSE_PERCENTAGE : integer = 45; //P6 % of timeout for pulse frequency. {-------------------------- TMult.Create -------------------------- ------------------------------------------------------------------} constructor TMult.Create(AOwner: TComponent); begin inherited Create(AOwner); FMultiple := TStringList.Create; end; {------------------------- TMult.Destroy -------------------------- ------------------------------------------------------------------} destructor TMult.Destroy; begin ClearAll; FMultiple.Free; FMultiple := nil; inherited Destroy; end; {-------------------------- TMult.Assign -------------------------- All of the items from source object are copied one by one into the target. So if the source is later destroyed, target object will continue to hold the copy of all elements, completely unaffected. ------------------------------------------------------------------} procedure TMult.Assign(Source: TPersistent); var I: integer; SourceStrings: TStrings; S: TString; SourceMult: TMult; begin ClearAll; if Source is TMult then begin SourceMult := Source as TMult; try for I := 0 to SourceMult.FMultiple.Count - 1 do begin S := TString.Create; S.Str := (SourceMult.FMultiple.Objects[I] as TString).Str; Self.FMultiple.AddObject(SourceMult.FMultiple[I], S); end; except end; end else begin SourceStrings := Source as TStrings; for I := 0 to SourceStrings.Count - 1 do Self[IntToStr(I)] := SourceStrings[I]; end; end; {------------------------- TMult.ClearAll ------------------------- One by one, all Mult items are freed. ------------------------------------------------------------------} procedure TMult.ClearAll; var I: integer; begin for I := 0 to FMultiple.Count - 1 do begin FMultiple.Objects[I].Free; FMultiple.Objects[I] := nil; end; FMultiple.Clear; end; {------------------------- TMult.GetCount ------------------------- Returns the number of elements in the multiple ------------------------------------------------------------------} function TMult.GetCount: Word; begin Result := FMultiple.Count; end; {------------------------- TMult.GetFirst ------------------------- Returns the subscript of the first element in the multiple ------------------------------------------------------------------} function TMult.GetFirst: string; begin if FMultiple.Count > 0 then Result := FMultiple[0] else Result := ''; end; {------------------------- TMult.GetLast -------------------------- Returns the subscript of the last element in the multiple ------------------------------------------------------------------} function TMult.GetLast: string; begin if FMultiple.Count > 0 then Result := FMultiple[FMultiple.Count - 1] else Result := ''; end; {---------------------- TMult.GetFMultiple ------------------------ Returns the VALUE of the element whose subscript is passed. ------------------------------------------------------------------} function TMult.GetFMultiple(Index: string): string; var S: TString; BrokerComponent,ParamRecord: TComponent; I: integer; strError: string; begin try S := TString(FMultiple.Objects[FMultiple.IndexOf(Index)]); except on EListError do begin {build appropriate error message} strError := iff(Self.Name <> '', Self.Name, 'TMult_instance'); strError := strError + '[' + Index + ']' + #13#10 + 'is undefined'; try ParamRecord := Self.Owner; BrokerComponent := Self.Owner.Owner.Owner; if (ParamRecord is TParamRecord) and (BrokerComponent is TRPCBroker) then begin I := 0; {if there is an easier way to figure out which array element points to this instance of a multiple, use it} // p13 while TRPCBroker(BrokerComponent).Param[I] <> ParamRecord do inc(I); strError := '.Param[' + IntToStr(I) + '].' + strError; strError := iff(BrokerComponent.Name <> '', BrokerComponent.Name, 'TRPCBroker_instance') + strError; end; except end; raise Exception.Create(strError); end; end; Result := S.Str; end; {---------------------- TMult.SetGetSorted ------------------------ ------------------------------------------------------------------} function TMult.GetSorted: boolean; begin Result := FMultiple.Sorted; end; {---------------------- TMult.SetFMultiple ------------------------ Stores a new element in the multiple. FMultiple (TStringList) is the structure, which is used to hold the subscript and value pair. Subscript is stored as the String, value is stored as an object of the string. ------------------------------------------------------------------} procedure TMult.SetFMultiple(Index: string; Value: string); var S: TString; Pos: integer; begin Pos := FMultiple.IndexOf(Index); {see if this subscript already exists} if Pos = -1 then begin {if subscript is new} S := TString.Create; {create string object} S.Str := Value; {put value in it} FMultiple.AddObject(Index, S); {add it} end else TString(FMultiple.Objects[Pos]).Str := Value; { otherwise replace the value} end; {---------------------- TMult.SetSorted ------------------------ ------------------------------------------------------------------} procedure TMult.SetSorted(Value: boolean); begin FMultiple.Sorted := Value; end; {-------------------------- TMult.Order -------------------------- Returns the subscript string of the next or previous element from the StartSubscript. This is very similar to the $O function available in M. Null string ('') is returned when reaching beyong the first or last element, or when list is empty. Note: A major difference between the M $O and this function is that in this function StartSubscript must identify a valid subscript in the list. ------------------------------------------------------------------} function TMult.Order(const StartSubscript: string; Direction: integer): string; var Index: longint; begin Result := ''; if StartSubscript = '' then if Direction > 0 then Result := First else Result := Last else begin Index := Position(StartSubscript); if Index > -1 then if (Index < (Count - 1)) and (Direction > 0) then Result := FMultiple[Index + 1] else if (Index > 0) and (Direction < 0) then Result := FMultiple[Index - 1]; end end; {------------------------- TMult.Position ------------------------- Returns the long integer value which is the index position of the element in the list. Opposite of TMult.Subscript(). Remember that the list is 0 based! ------------------------------------------------------------------} function TMult.Position(const Subscript: string): longint; begin Result := FMultiple.IndexOf(Subscript); end; {------------------------ TMult.Subscript ------------------------- Returns the string subscript of the element whose position in the list is passed in. Opposite of TMult.Position(). Remember that the list is 0 based! ------------------------------------------------------------------} function TMult.Subscript(const Position: longint): string; begin Result := ''; if (Position > -1) and (Position < Count) then Result := FMultiple[Position]; end; {---------------------- TParamRecord.Create ----------------------- Creates TParamRecord instance and automatically creates TMult. The name of Mult is also set in case it may be need if exception will be raised. ------------------------------------------------------------------} constructor TParamRecord.Create(AOwner: TComponent); begin inherited Create(AOwner); FMult := TMult.Create(Self); FMult.Name := 'Mult'; {note: FMult is destroyed in the SetClearParameters method} end; destructor TParamRecord.Destroy; begin FMult.Free; FMult := nil; inherited; end; {------------------------- TParams.Create ------------------------- ------------------------------------------------------------------} constructor TParams.Create(AOwner: TComponent); begin inherited Create(AOwner); FParameters := TList.Create; {for now, empty list} end; {------------------------ TParams.Destroy ------------------------- ------------------------------------------------------------------} destructor TParams.Destroy; begin Clear; {clear the Multiple first!} FParameters.Free; FParameters := nil; inherited Destroy; end; {------------------------- TParams.Assign ------------------------- ------------------------------------------------------------------} procedure TParams.Assign(Source: TPersistent); var I: integer; SourceParams: TParams; begin Self.Clear; SourceParams := Source as TParams; for I := 0 to SourceParams.Count - 1 do begin Self[I].Value := SourceParams[I].Value; Self[I].PType := SourceParams[I].PType; Self[I].Mult.Assign(SourceParams[I].Mult); end end; {------------------------- TParams.Clear -------------------------- ------------------------------------------------------------------} procedure TParams.Clear; var ParamRecord: TParamRecord; I: integer; begin if FParameters <> nil then begin for I := 0 to FParameters.Count - 1 do begin ParamRecord := TParamRecord(FParameters.Items[I]); if ParamRecord <> nil then begin //could be nil if params were skipped by developer ParamRecord.FMult.Free; ParamRecord.FMult := nil; ParamRecord.Free; end; end; FParameters.Clear; {release FParameters TList} end; end; {------------------------ TParams.GetCount ------------------------ ------------------------------------------------------------------} function TParams.GetCount: Word; begin if FParameters = nil then Result := 0 else Result := FParameters.Count; end; {---------------------- TParams.GetParameter ---------------------- ------------------------------------------------------------------} function TParams.GetParameter(Index: integer): TParamRecord; begin if Index >= FParameters.Count then {if element out of bounds,} while FParameters.Count <= Index do FParameters.Add(nil); {setup place holders} if FParameters.Items[Index] = nil then begin {if just a place holder,} {point it to new memory block} FParameters.Items[Index] := TParamRecord.Create(Self); TParamRecord(FParameters.Items[Index]).PType := undefined; {initialize} end; Result := FParameters.Items[Index]; {return requested parameter} end; {---------------------- TParams.SetParameter ---------------------- ------------------------------------------------------------------} procedure TParams.SetParameter(Index: integer; Parameter: TParamRecord); begin if Index >= FParameters.Count then {if element out of bounds,} while FParameters.Count <= Index do FParameters.Add(nil); {setup place holders} if FParameters.Items[Index] = nil then {if just a place holder,} FParameters.Items[Index] := Parameter; {point it to passed parameter} end; {------------------------ TRPCBroker.Create ----------------------- ------------------------------------------------------------------} constructor TRPCBroker.Create(AOwner: TComponent); begin inherited Create(AOwner); {set defaults} // This constant defined in the interface section needs to be updated for each release FBrokerVersion := CURRENT_RPC_VERSION; FClearParameters := boolean(StrToInt (ReadRegDataDefault(HKLM,REG_BROKER,'ClearParameters','1'))); FClearResults := boolean(StrToInt (ReadRegDataDefault(HKLM,REG_BROKER,'ClearResults','1'))); FDebugMode := False; FParams := TParams.Create(Self); FResults := TStringList.Create; FServer := ReadRegDataDefault(HKLM,REG_BROKER,'Server','BROKERSERVER'); FPulse := TTimer.Create(Self); //P6 FListenerPort := StrToInt (ReadRegDataDefault(HKLM,REG_BROKER,'ListenerPort','9200')); FRpcVersion := '0'; FRPCTimeLimit := MIN_RPCTIMELIMIT; with FPulse do ///P6 begin Enabled := False; //P6 Interval := DEFAULT_PULSE; //P6 OnTimer := DoPulseOnTimer; //P6 end; FLogin := TVistaLogin.Create(Self); //p13 FKernelLogin := True; //p13 FUser := TVistaUser.Create; //p13 FShowErrorMsgs := semRaise; //p13 XWBWinsock := TXWBWinsock.Create; FIsBackwardCompatibleConnection := True; // default Application.ProcessMessages; end; {----------------------- TRPCBroker.Destroy ----------------------- ------------------------------------------------------------------} destructor TRPCBroker.Destroy; begin Connected := False; TXWBWinsock(XWBWinsock).Free; FParams.Free; FParams := nil; FResults.Free; FResults := nil; FPulse.Free; //P6 FPulse := nil; FUser.Free; FUser := nil; FLogin.Free; FLogin := nil; inherited Destroy; end; {--------------------- TRPCBroker.CreateContext ------------------- This function is part of the overall Broker security. The passed context string is essentially a Client/Server type option on the server. The server sets up MenuMan environment variables for this context which will later be used to screen RPCs. Only those RPCs which are in the multiple field of this context option will be permitted to run. ------------------------------------------------------------------} function TRPCBroker.CreateContext(strContext: string): boolean; var InternalBroker: TRPCBroker; {use separate component} Str: String; begin Result := False; Connected := True; InternalBroker := nil; try InternalBroker := TRPCBroker.Create(Self); InternalBroker.FSocket := Self.Socket; // p13 -- permits multiple broker connections to same server/port with InternalBroker do begin { TXWBWinsock(InternalBroker.XWBWinsock).IsBackwardsCompatible := TXWBWinsock(Self.XWBWinsock).IsBackwardsCompatible; TXWBWinsock(InternalBroker.XWBWinsock).OriginalConnectionOnly := TXWBWinsock(Self.XWBWinsock).OriginalConnectionOnly; } Tag := 1234; // 060919 added to support multiple brokers with both old and new connections Prefix := Self.Prefix; // type of connection TXWBWinsock(InternalBroker.XWBWinsock).Prefix := Prefix; // 060919 end of addition ShowErrorMsgs := Self.ShowerrorMsgs; Server := Self.Server; {inherit application server} ListenerPort := Self.ListenerPort; {inherit listener port} DebugMode := Self.DebugMode; {inherit debug mode property} RemoteProcedure := 'XWB CREATE CONTEXT'; {set up RPC} Param[0].PType := literal; Param[0].Value := Encrypt(strContext); try Str := strCall; if Str = '1' then begin // make the call // p13 Result := True; // p13 self.FCurrentContext := strContext; // p13 end // p13 else begin Result := False; self.FCurrentContext := ''; end; except // Code added to return False if User doesn't have access on e: EBrokerError do begin self.FCurrentContext := ''; if Pos('does not have access to option',e.Message) > 0 then begin Result := False end else Raise; end; end; if RPCBError <> '' then self.RPCBError := RPCBError; end; finally InternalBroker.XWBWinsock := nil; InternalBroker.Free; {release memory} end; end; {------------------------ TRPCBroker.Loaded ----------------------- ------------------------------------------------------------------} procedure TRPCBroker.Loaded; begin inherited Loaded; end; {------------------------- TRPCBroker.Call ------------------------ ------------------------------------------------------------------} procedure TRPCBroker.Call; var ResultBuffer: TStrings; begin ResultBuffer := TStringList.Create; try if ClearResults then ClearResults := True; lstCall(ResultBuffer); Self.Results.AddStrings(ResultBuffer); finally ResultBuffer.Clear; ResultBuffer.Free; end; end; {----------------------- TRPCBroker.lstCall ----------------------- ------------------------------------------------------------------} procedure TRPCBroker.lstCall(OutputBuffer: TStrings); var ManyStrings: PChar; begin ManyStrings := pchCall; {make the call} OutputBuffer.SetText(ManyStrings); {parse result of call, format as list} StrDispose(ManyStrings); {raw result no longer needed, get back mem} end; {----------------------- TRPCBroker.strCall ----------------------- ------------------------------------------------------------------} function TRPCBroker.strCall: string; var ResultString: PChar; begin ResultString := pchCall; {make the call} Result := StrPas(ResultString); {convert and present as Pascal string} StrDispose(ResultString); {raw result no longer needed, get back mem} end; {--------------------- TRPCBroker.SetConnected -------------------- ------------------------------------------------------------------} procedure TRPCBroker.SetConnected(Value: Boolean); var thisOwner: TComponent; RPCBContextor: TContextorControl; thisParent: TForm; BrokerDir, Str1, Str2, Str3 :string; // 060920 added to support SSH connection PseudoPort: Integer; PseudoServer, PseudoPortStr: String; begin RPCBError := ''; Login.ErrorText := ''; if (Connected <> Value) and not(csReading in ComponentState) then begin if Value and (FConnecting <> Value) then begin {connect} // if change servers, remove SSH port, username, pw if not (FLastServer = '') then begin if (not (FLastServer = Server)) or (not (FLastPort = ListenerPort)) then begin SSHport := ''; SSHUser := ''; SSHpw := ''; end; end; FLastServer := Server; FLastPort := ListenerPort; // FSocket := ExistingSocket(Self); FConnecting := True; // FConnected := True; try if FSocket = 0 then begin {Execute Client Agent from directory in Registry.} BrokerDir := ReadRegData(HKLM, REG_BROKER, 'BrokerDr'); if BrokerDir <> '' then ProcessExecute(BrokerDir + '\ClAgent.Exe', sw_ShowNoActivate) else ProcessExecute('ClAgent.Exe', sw_ShowNoActivate); if DebugMode and (not OldConnectionOnly) then begin Str1 := 'Control of debugging has been moved from the client to the server. To start a Debug session, do the following:'+#13#10#13#10; Str2 := '1. On the server, set initial breakpoints where desired.'+#13#10+'2. DO DEBUG^XWBTCPM.'+#13#10+'3. Enter a unique Listener port number (i.e., a port number not in general use).'+#13#10; Str3 := '4. Connect the client application using the port number entered in Step #3.'; ShowMessage(Str1 + Str2 + Str3); end; CheckSSH; if not (FUseSecureConnection = secureNone) then begin if not StartSecureConnection(PseudoServer, PseudoPortStr) then exit; // Val(PseudoPortStr,PseudoPort,Code) PseudoPort := StrToInt(PseudoPortStr); end else begin PseudoPort := ListenerPort; PseudoServer := Server; end; TXWBWinsock(XWBWinsock).IsBackwardsCompatible := FIsBackwardCompatibleConnection; TXWBWinsock(XWBWinsock).OldConnectionOnly := FOldConnectionOnly; FSocket := TXWBWinsock(XWBWinsock).NetworkConnect(DebugMode, PseudoServer, // FServer, PseudoPort, FRPCTimeLimit); Prefix := TXWBWinsock(XWBWinsock).Prefix; FIsNewStyleConnection := TXWBWinsock(XWBWinsock).IsNewStyle; AuthenticateUser(Self); StoreConnection(Self); //MUST store connection before CreateContext() //CCOW start if (FContextor <> nil) and (length(CCOWtoken) = 0) then begin //Get new CCOW token CCOWToken := GetCCOWHandle(Self); if Length(CCOWToken) > 0 then begin try RPCBContextor := TContextorControl.Create(Application); RPCBContextor.Run('BrokerLoginModule#', PassCode1+PassCode2, TRUE, '*'); CCOWsetUser(user.name, CCOWToken, Domain, user.Vpid, RPCBContextor); //Clear token FCCOWLogonIDName := CCOW_LOGON_ID; FCCOWLogonIdValue := Domain; FCCOWLogonName := CCOW_LOGON_NAME; FCCOWLogonNameValue := user.name; if user.name <> '' then FWasUserDefined := True; FCCOWLogonVpid := CCOW_LOGON_VPID; FCCOWLogonVpidValue := user.Vpid; RPCBContextor.Free; RPCBContextor := nil; except ShowMessage('Problem with Contextor.Run'); FreeAndNil(RPCBContextor); end; end; // if Length(CCOWToken) > 0 end; //if //CCOW end FPulse.Enabled := True; //P6 Start heartbeat. CreateContext(''); //Closes XUS SIGNON context. end else begin //p13 StoreConnection(Self); FPulse.Enabled := True; //p13 end; //p13 FConnected := True; // jli mod 12/17/01 FConnecting := False; // 080620 If connected via SSH, With no command box // visible, should let users know they have it. if not (CommandBoxProcessHandle = 0) then begin thisOwner := self.Owner; if (thisOwner is TForm) then begin thisParent := TForm(self.Owner); if not (Pos('(SSH Secure connection)',thisParent.Caption) > 0) then thisParent.Caption := thisParent.Caption + ' (SSH Secure connection)'; end; end; except on E: EBrokerError do begin if E.Code = XWB_BadSignOn then TXWBWinsock(XWBWinsock).NetworkDisconnect(FSocket); FSocket := 0; FConnected := False; FConnecting := False; if not (CommandBoxProcessHandle = 0) then TerminateProcess(CommandBoxProcessHandle,10); FRPCBError := E.Message; // p13 handle errors as specified if Login.ErrorText <> '' then FRPCBError := E.Message + chr(10) + Login.ErrorText; if Assigned(FOnRPCBFailure) then // p13 FOnRPCBFailure(Self) // p13 else if ShowErrorMsgs = semRaise then Raise; // p13 // raise; {this is where I would do OnNetError} end{on}; end{try}; end{if} else if not Value then begin //p13 FConnected := False; //p13 FPulse.Enabled := False; //p13 if RemoveConnection(Self) = NoMore then begin {FPulse.Enabled := False; ///P6;p13 } TXWBWinsock(XWBWinsock).NetworkDisconnect(Socket); {actually disconnect from server} FSocket := 0; {store internal} //FConnected := False; //p13 // 080618 following added to close command box if SSH is being used if not (CommandBoxProcessHandle = 0) then begin TerminateProcess(CommandBoxProcessHandle,10); thisOwner := self.Owner; if (thisOwner is TForm) then begin thisParent := TForm(self.Owner); if (Pos('(SSH Secure connection)',thisParent.Caption) > 0) then begin // 080620 remove ' (SSH Secure connection)' on disconnection thisParent.Caption := Copy(thisParent.Caption,1,Length(thisParent.Caption)-24); end; end; end; end{if}; end; {else} end{if}; end; {----------------- TRPCBroker.SetClearParameters ------------------ ------------------------------------------------------------------} procedure TRPCBroker.SetClearParameters(Value: Boolean); begin if Value then FParams.Clear; FClearParameters := Value; end; {------------------- TRPCBroker.SetClearResults ------------------- ------------------------------------------------------------------} procedure TRPCBroker.SetClearResults(Value: Boolean); begin if Value then begin {if True} FResults.Clear; end; FClearResults := Value; end; {---------------------- TRPCBroker.SetResults --------------------- ------------------------------------------------------------------} procedure TRPCBroker.SetResults(Value: TStrings); begin FResults.Assign(Value); end; {----------------------- TRPCBroker.SetRPCTimeLimit ----------------- ------------------------------------------------------------------} procedure TRPCBroker.SetRPCTimeLimit(Value: integer); begin if Value <> FRPCTimeLimit then if Value > MIN_RPCTIMELIMIT then FRPCTimeLimit := Value else FRPCTimeLimit := MIN_RPCTIMELIMIT; end; {----------------------- TRPCBroker.SetServer --------------------- ------------------------------------------------------------------} procedure TRPCBroker.SetServer(Value: TServer); begin {if changing the name of the server, make sure to disconnect first} if (Value <> FServer) and Connected then begin Connected := False; end; FServer := Value; end; {--------------------- TRPCBroker.pchCall ---------------------- Lowest level remote procedure call that a TRPCBroker component can make. 1. Returns PChar. 2. Converts Remote Procedure to PChar internally. ------------------------------------------------------------------} function TRPCBroker.pchCall: PChar; var Value, Sec, App: PChar; BrokerError: EBrokerError; blnRestartPulse : boolean; //P6 begin RPCBError := ''; Connected := True; BrokerError := nil; Value := nil; blnRestartPulse := False; //P6 Sec := StrAlloc(255); App := StrAlloc(255); try if FPulse.Enabled then ///P6 If Broker was sending pulse, begin FPulse.Enabled := False; /// Stop pulse & blnRestartPulse := True; // Set flag to restart pulse after RPC. end; { if Assigned(FOnRPCCall) then begin FOnRPCCall(Self, 1, RemoteProcedure, CurrentContext, RpcVersion, Param, FRPCTimeLimit, '', '', '', Now); end; } try Value := TXWBWinsock(XWBWinsock).tCall(Socket, RemoteProcedure, RpcVersion, Param, Sec, App,FRPCTimeLimit); { if Assigned(FOnRPCCall) then begin FOnRPCCall(Self, 2, RemoteProcedure, CurrentContext, RpcVersion, Param, FRPCTimeLimit, Result, Sec, App, Now); end; } if (StrLen(Sec) > 0) then begin BrokerError := EBrokerError.Create(StrPas(Sec)); BrokerError.Code := 0; BrokerError.Action := 'Error Returned'; end; except on Etemp: EBrokerError do with Etemp do begin //save copy of error BrokerError := EBrokerError.Create(message); //field by field BrokerError.Action := Action; BrokerError.Code := Code; BrokerError.Mnemonic := Mnemonic; if Value <> nil then StrDispose(Value); Value := StrNew(''); {if severe error, mark connection as closed. Per Enrique, we should replace this check with some function, yet to be developed, which will test the link.} if ((Code >= 10050)and(Code <=10058))or(Action = 'connection lost') then begin Connected := False; blnRestartPulse := False; //P6 end; end; end; finally StrDispose(Sec); {do something with these} Sec := nil; StrDispose(App); App := nil; if ClearParameters then ClearParameters := True; //prepare for next call end; Result := Value; if Result = nil then Result := StrNew(''); //return empty string if blnRestartPulse then FPulse.Enabled := True; //Restart pulse. (P6) if BrokerError <> nil then begin FRPCBError := BrokerError.Message; // p13 handle errors as specified if Login.ErrorText <> '' then FRPCBError := BrokerError.Message + chr(10) + Login.ErrorText; if Assigned(FOnRPCBFailure) then // p13 begin FOnRPCBFailure(Self); StrDispose(Result); end else if FShowErrorMsgs = semRaise then begin StrDispose(Result); // return memory we won't use - caused a memory leak Raise BrokerError; // p13 end else // silent, just return error message in FRPCBError BrokerError.Free; // return memory in BrokerError - otherwise is a memory leak // raise; {this is where I would do OnNetError} end; // if BrokerError <> nil end; {-------------------------- DisconnectAll ------------------------- Find all connections in BrokerAllConnections list for the passed in server:listenerport combination and disconnect them. If at least one connection to the server:listenerport is found, then it and all other Brokers to the same server:listenerport will be disconnected; True will be returned. Otherwise False will return. ------------------------------------------------------------------} function DisconnectAll(Server: string; ListenerPort: integer): boolean; var Index: integer; begin Result := False; while (Assigned(BrokerAllConnections) and (BrokerAllConnections.Find(Server + ':' + IntToStr(ListenerPort), Index))) do begin Result := True; TRPCBroker(BrokerAllConnections.Objects[Index]).Connected := False; {if the call above disconnected the last connection in the list, then the whole list will be destroyed, making it necessary to check if it's still assigned.} end; end; {------------------------- StoreConnection ------------------------ Each broker connection is stored in BrokerConnections list. ------------------------------------------------------------------} procedure StoreConnection(Broker: TRPCBroker); begin if BrokerConnections = nil then {list is created when 1st entry is added} try BrokerConnections := TStringList.Create; BrokerConnections.Sorted := True; BrokerConnections.Duplicates := dupAccept; {store every connection} BrokerAllConnections := TStringList.Create; BrokerAllConnections.Sorted := True; BrokerAllConnections.Duplicates := dupAccept; except TXWBWinsock(Broker.XWBWinsock).NetError('store connection',XWB_BldConnectList) end; BrokerAllConnections.AddObject(Broker.Server + ':' + IntToStr(Broker.ListenerPort), Broker); BrokerConnections.AddObject(IntToStr(Broker.Socket), Broker); end; {------------------------ RemoveConnection ------------------------ Result of this function will be False, if there are no more connections to the same server:listenerport as the passed in Broker. If at least one other connection is found to the same server:listenerport, then Result will be True. ------------------------------------------------------------------} function RemoveConnection(Broker: TRPCBroker): boolean; var Index: integer; begin Result := False; if Assigned(BrokerConnections) then begin {remove connection record of passed in Broker component} BrokerConnections.Delete(BrokerConnections.IndexOfObject(Broker)); {look for one other connection to the same server:port} // Result := BrokerConnections.Find(Broker.Server + ':' + IntToStr(Broker.ListenerPort), Index); Result := BrokerConnections.Find(IntToStr(Broker.Socket), Index); if BrokerConnections.Count = 0 then begin {if last entry removed,} BrokerConnections.Free; {destroy whole list structure} BrokerConnections := nil; end; end; // if Assigned(BrokerConnections) if Assigned(BrokerAllConnections) then begin BrokerAllConnections.Delete(BrokerAllConnections.IndexOfObject(Broker)); if BrokerAllConnections.Count = 0 then begin BrokerAllConnections.Free; BrokerAllConnections := nil; end; end; // if Assigned(BrokerAllConnections) end; {------------------------- ExistingSocket ------------------------- ------------------------------------------------------------------} function ExistingSocket(Broker: TRPCBroker): integer; // var // Index: integer; begin Result := Broker.Socket; { Result := 0; // p13 to permit multiple Broker connections if Assigned(BrokerConnections) and BrokerConnections.Find(Broker.Server + ':' + IntToStr(Broker.ListenerPort), Index) then Result := TRPCBroker(BrokerConnections.Objects[Index]).Socket; } end; {------------------------ AuthenticateUser ------------------------ ------------------------------------------------------------------} procedure AuthenticateUser(ConnectingBroker: TRPCBroker); var SaveClearParmeters, SaveClearResults: boolean; SaveParam: TParams; SaveRemoteProcedure, SaveRpcVersion: string; SaveResults: TStrings; blnSignedOn: boolean; SaveKernelLogin: boolean; SaveVistaLogin: TVistaLogin; OldExceptionHandler: TExceptionEvent; OldHandle: THandle; begin With ConnectingBroker do begin SaveParam := TParams.Create(nil); SaveParam.Assign(Param); //save off settings SaveRemoteProcedure := RemoteProcedure; SaveRpcVersion := RpcVersion; SaveResults := Results; SaveClearParmeters := ClearParameters; SaveClearResults := ClearResults; ClearParameters := True; //set'em as I need'em ClearResults := True; SaveKernelLogin := FKernelLogin; // p13 SaveVistaLogin := FLogin; // p13 end; try blnSignedOn := False; //initialize to bad sign-on if ConnectingBroker.AccessVerifyCodes <> '' then // p13 handle as AVCode single signon begin ConnectingBroker.Login.AccessCode := Piece(ConnectingBroker.AccessVerifyCodes, ';', 1); ConnectingBroker.Login.VerifyCode := Piece(ConnectingBroker.AccessVerifyCodes, ';', 2); ConnectingBroker.Login.Mode := lmAVCodes; ConnectingBroker.FKernelLogIn := False; end; //CCOW start if ConnectingBroker.KernelLogIn and (not (ConnectingBroker.Contextor = nil)) then begin CCOWtoken := ConnectingBroker.GetCCOWtoken(ConnectingBroker.Contextor); if length(CCOWtoken)>0 then begin ConnectingBroker.FKernelLogIn := false; ConnectingBroker.Login.Mode := lmAppHandle; ConnectingBroker.Login.LogInHandle := CCOWtoken; end; end; //CCOW end if ConnectingBroker.FKernelLogIn then begin //p13 CCOWToken := ''; // 061201 JLI if can't sign on with Token clear it so can get new one if Assigned(Application.OnException) then OldExceptionHandler := Application.OnException else OldExceptionHandler := nil; Application.OnException := TfrmErrMsg.RPCBShowException; frmSignon := TfrmSignon.Create(Application); try // ShowApplicationAndFocusOK(Application); OldHandle := GetForegroundWindow; SetForegroundWindow(frmSignon.Handle); PrepareSignonForm(ConnectingBroker); if SetUpSignOn then //SetUpSignOn in loginfrm unit. begin //True if signon needed if frmSignOn.lblServer.Caption <> '' then begin frmSignOn.ShowModal; //do interactive logon // p13 if frmSignOn.Tag = 1 then //Tag=1 for good logon blnSignedOn := True; //Successfull logon end end else //False when no logon needed blnSignedOn := NoSignOnNeeded; //Returns True always (for now!) if blnSignedOn then //P6 If logged on, retrieve user info. begin GetBrokerInfo(ConnectingBroker); if not SelDiv.ChooseDiv('',ConnectingBroker) then begin blnSignedOn := False;//P8 {Select division if multi-division user. First parameter is 'userid' (DUZ or username) for future use. (P8)} ConnectingBroker.Login.ErrorText := 'Failed to select Division'; // p13 set some text indicating problem end; end; SetForegroundWindow(OldHandle); finally frmSignon.Free; // frmSignon.Release; //get rid of signon form // if ConnectingBroker.Owner is TForm then // SetForegroundWindow(TForm(ConnectingBroker.Owner).Handle) // else // SetForegroundWindow(ActiveWindow); ShowApplicationAndFocusOK(Application); end ; //try if Assigned(OldExceptionHandler) then Application.OnException := OldExceptionHandler; end; //if kernellogin // p13 following section for silent signon if not ConnectingBroker.FKernelLogIn then if ConnectingBroker.FLogin <> nil then //the user. vistalogin contains login info blnsignedon := SilentLogin(ConnectingBroker); // RpcSLogin unit if not blnsignedon then begin ConnectingBroker.FLogin.FailedLogin(ConnectingBroker.FLogin); TXWBWinsock(ConnectingBroker.XWBWinsock).NetworkDisconnect(ConnectingBroker.FSocket); end else GetBrokerInfo(ConnectingBroker); finally //reset the Broker with ConnectingBroker do begin ClearParameters := SaveClearParmeters; ClearResults := SaveClearResults; Param.Assign(SaveParam); //restore settings SaveParam.Free; RemoteProcedure := SaveRemoteProcedure; RpcVersion := SaveRpcVersion; Results := SaveResults; FKernelLogin := SaveKernelLogin; // p13 FLogin := SaveVistaLogin; // p13 end; end; if not blnSignedOn then //Flag for unsuccessful signon. TXWBWinsock(ConnectingBroker.XWBWinsock).NetError('',XWB_BadSignOn); //Will raise error. end; {------------------------ GetBrokerInfo ------------------------ P6 Retrieve information about user with XWB GET BROKER INFO RPC. For now, only Timeout value is retrieved in Results[0]. ------------------------------------------------------------------} procedure GetBrokerInfo(ConnectedBroker: TRPCBroker); begin GetUserInfo(ConnectedBroker); // p13 Get User info into User property (TVistaUser object) With ConnectedBroker do //(dcm) Use one of objects below begin // and skip this RPC? or make this and RemoteProcedure := 'XWB GET BROKER INFO'; // others below as components try Call; if Results.Count > 0 then if StrToInt(Results[0]) > MINIMUM_TIMEOUT then FPulse.Interval := (StrToInt(Results[0]) * 10 * PULSE_PERCENTAGE); except On e: EBrokerError do ShowMessage('A problem was encountered getting Broker information. '+e.Message); //TODO end; end; end; {------------------------ NoSignOnNeeded ------------------------ ------------------------------------------------------------------} {Currently a placeholder for actions that may be needed in connection with authenticating a user who needn't sign on (Single Sign on feature). Returns True if no signon is needed False if signon is needed.} function NoSignOnNeeded : Boolean; begin Result := True; end; {------------------------- ProcessExecute ------------------------- This function is borrowed from "Delphi 2 Developer's Guide" by Pacheco & Teixera. See chapter 11, page 406. It encapsulates and simplifies use of Windows CreateProcess function. ------------------------------------------------------------------} function ProcessExecute(Command: string; cShow: Word): Integer; { This method encapsulates the call to CreateProcess() which creates a new process and its primary thread. This is the method used in Win32 to execute another application, This method requires the use of the TStartInfo and TProcessInformation structures. These structures are not documented as part of the Delphi 2.0 online help but rather the Win32 help as STARTUPINFO and PROCESS_INFORMATION. The CommandLine paremeter specifies the pathname of the file to execute. The cShow paremeter specifies one of the SW_XXXX constants which specifies how to display the window. This value is assigned to the sShowWindow field of the TStartupInfo structure. } var Rslt: LongBool; StartUpInfo: TStartUpInfo; // documented as STARTUPINFO ProcessInfo: TProcessInformation; // documented as PROCESS_INFORMATION begin { Clear the StartupInfo structure } FillChar(StartupInfo, SizeOf(TStartupInfo), 0); { Initialize the StartupInfo structure with required data. Here, we assign the SW_XXXX constant to the wShowWindow field of StartupInfo. When specifing a value to this field the STARTF_USESSHOWWINDOW flag must be set in the dwFlags field. Additional information on the TStartupInfo is provided in the Win32 online help under STARTUPINFO. } with StartupInfo do begin cb := SizeOf(TStartupInfo); // Specify size of structure dwFlags := STARTF_USESHOWWINDOW or STARTF_FORCEONFEEDBACK; wShowWindow := cShow end; { Create the process by calling CreateProcess(). This function fills the ProcessInfo structure with information about the new process and its primary thread. Detailed information is provided in the Win32 online help for the TProcessInfo structure under PROCESS_INFORMATION. } Rslt := CreateProcess(PChar(Command), nil, nil, nil, False, NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo); { If Rslt is true, then the CreateProcess call was successful. Otherwise, GetLastError will return an error code representing the error which occurred. } if Rslt then with ProcessInfo do begin { Wait until the process is in idle. } WaitForInputIdle(hProcess, INFINITE); CloseHandle(hThread); // Free the hThread handle CloseHandle(hProcess);// Free the hProcess handle Result := 0; // Set Result to 0, meaning successful end else Result := GetLastError; // Set result to the error code. end; {----------------------- GetAppHandle -------------------------- Library function to return an Application Handle from the server which can be passed as a command line argument to an application the current application is starting. The new application can use this AppHandle to perform a silent login via the lmAppHandle mode ----------------------------------------------------------------} function GetAppHandle(ConnectedBroker : TRPCBroker): String; // p13 begin Result := ''; with ConnectedBroker do begin RemoteProcedure := 'XUS GET TOKEN'; Call; Result := Results[0]; end; end; {----------------------- TRPCBroker.DoPulseOnTimer----------------- Called from the OnTimer event of the Pulse property. Broker environment should be the same after the procedure as before. Note: Results is not changed by strCall; so, Results needn't be saved. ------------------------------------------------------------------} procedure TRPCBroker.DoPulseOnTimer(Sender: TObject); //P6 var SaveClearParameters : Boolean; SaveParam : TParams; SaveRemoteProcedure, SaveRPCVersion : string; begin SaveClearParameters := ClearParameters; //Save existing properties SaveParam := TParams.Create(nil); SaveParam.Assign(Param); SaveRemoteProcedure := RemoteProcedure; SaveRPCVersion := RPCVersion; RemoteProcedure := 'XWB IM HERE'; //Set Properties for IM HERE ClearParameters := True; //Erase existing PARAMs RPCVersion := '1.106'; try try strCall; //Make the call except on e: EBrokerError do begin // Connected := False; // set the connection as disconnected if Assigned(FOnPulseError) then FOnPulseError(Self, e.Message) else raise e; end; end; finally ClearParameters := SaveClearParameters; //Restore pre-existing properties. Param.Assign(SaveParam); SaveParam.Free; RemoteProcedure := SaveRemoteProcedure; RPCVersion := SaveRPCVersion; end; end; procedure TRPCBroker.SetKernelLogIn(const Value: Boolean); // p13 begin FKernelLogIn := Value; end; { procedure TRPCBroker.SetLogIn(const Value: TVistaLogIn); // p13 begin FLogIn := Value; end; } procedure TRPCBroker.SetUser(const Value: TVistaUser); // p13 begin FUser := Value; end; {*****TVistaLogin***** p13} constructor TVistaLogin.Create(AOwner: TComponent); // p13 begin inherited create; FDivLst := TStringList.Create; end; destructor TVistaLogin.Destroy; // p13 begin FDivLst.Free; FDivLst := nil; inherited; end; procedure TVistaLogin.FailedLogin(Sender: TObject); // p13 begin if Assigned(FOnFailedLogin) then FOnFailedLogin(Self) else TXWBWinsock(TRPCBroker(Sender).XWBWinsock).NetError('',XWB_BadSignOn); end; procedure TVistaLogin.SetAccessCode(const Value: String); // p13 begin FAccessCode := Value; end; procedure TVistaLogin.SetDivision(const Value: String); // p13 begin FDivision := Value; end; procedure TVistaLogin.SetDuz(const Value: string); // p13 begin FDUZ := Value; end; procedure TVistaLogin.SetErrorText(const Value: string); // p13 begin FErrorText := Value; end; procedure TVistaLogin.SetLogInHandle(const Value: String); // p13 begin FLogInHandle := Value; end; procedure TVistaLogin.SetMode(const Value: TLoginMode); // p13 begin FMode := Value; end; procedure TVistaLogin.SetMultiDivision(Value: Boolean); // p13 begin FMultiDivision := Value; end; procedure TVistaLogin.SetNTToken(const Value: String); // p13 begin end; procedure TVistaLogin.SetPromptDiv(const Value: boolean); // p13 begin FPromptDiv := Value; end; procedure TVistaLogin.SetVerifyCode(const Value: String); // p13 begin FVerifyCode := Value; end; {***** TVistaUser ***** p13 } procedure TVistaUser.SetDivision(const Value: String); // p13 begin FDivision := Value; end; procedure TVistaUser.SetDTime(const Value: string); // p13 begin FDTime := Value; end; procedure TVistaUser.SetDUZ(const Value: String); // p13 begin FDUZ := Value; end; procedure TVistaUser.SetLanguage(const Value: string); // p13 begin FLanguage := Value; end; procedure TVistaUser.SetName(const Value: String); // p13 begin FName := Value; end; procedure TVistaUser.SetServiceSection(const Value: string); // p13 begin FServiceSection := Value; end; procedure TVistaUser.SetStandardName(const Value: String); // p13 begin FStandardName := Value; end; procedure TVistaUser.SetTitle(const Value: string); // p13 begin FTitle := Value; end; procedure TVistaUser.SetVerifyCodeChngd(const Value: Boolean); // p13 begin FVerifyCodeChngd := Value; end; Function ShowApplicationAndFocusOK(anApplication: TApplication): boolean; var j: integer; Stat2: set of (sWinVisForm,sWinVisApp,sIconized); hFGWnd: THandle; begin Stat2 := []; {sWinVisForm,sWinVisApp,sIconized} If anApplication.MainForm <> nil then If IsWindowVisible(anApplication.MainForm.Handle) then Stat2 := Stat2 + [sWinVisForm]; If IsWindowVisible(anApplication.Handle) then Stat2 := Stat2 + [sWinVisApp]; If IsIconic(anApplication.Handle) then Stat2 := Stat2 + [sIconized]; Result := true; If sIconized in Stat2 then begin {A} j := SendMessage(anApplication.Handle,WM_SYSCOMMAND,SC_RESTORE,0); Result := j<>0; end; If Stat2 * [sWinVisForm,sIconized] = [] then begin {S} if anApplication.MainForm <> nil then anApplication.MainForm.Show; end; If (Stat2 * [sWinVisForm,sIconized] <> []) or (sWinVisApp in Stat2) then begin {G} {$IFNDEF D6_OR_HIGHER} hFGWnd := GetForegroundWindow; try AttachThreadInput( GetWindowThreadProcessId(hFGWnd, nil), GetCurrentThreadId,True); Result := SetForegroundWindow(anApplication.Handle); finally AttachThreadInput( GetWindowThreadProcessId(hFGWnd, nil), GetCurrentThreadId, False); end; {$ENDIF} end; end; function TRPCBroker.WasUserDefined: Boolean; begin Result := FWasUserDefined; end; function TRPCBroker.IsUserCleared: Boolean; var CCOWcontextItem: IContextItemCollection; //CCOW CCOWdataItem1: IContextItem; //CCOW Name: String; begin Result := False; Name := CCOW_LOGON_ID; if (Contextor <> nil) then try //See if context contains the ID item CCOWcontextItem := Contextor.CurrentContext; CCOWDataItem1 := CCowContextItem.Present(Name); if (CCOWdataItem1 <> nil) then //1 begin If CCOWdataItem1.Value = '' then Result := True else FWasUserDefined := True; end else Result := True; finally end; //try end; {----------------------- GetCCOWHandle -------------------------- Private function to return a special CCOW Handle from the server which is set into the CCOW context. The Broker of a new application can get the CCOWHandle from the context and use it to do a ImAPPHandle Sign-on. ----------------------------------------------------------------} function TRPCBroker.GetCCOWHandle(ConnectedBroker : TRPCBroker): String; // p13 begin Result := ''; with ConnectedBroker do try // to permit it to work correctly if CCOW is not installed on the server. begin RemoteProcedure := 'XUS GET CCOW TOKEN'; Call; Result := Results[0]; Domain := Results[1]; RemoteProcedure := 'XUS CCOW VAULT PARAM'; Call; PassCode1 := Results[0]; PassCode2 := Results[1]; end; except Result := ''; end; end; //CCOW start procedure TRPCBroker.CCOWsetUser(Uname, token, Domain, Vpid: string; Contextor: TContextorControl); var CCOWdata: IContextItemCollection; //CCOW CCOWdataItem1,CCOWdataItem2,CCOWdataItem3: IContextItem; CCOWdataItem4,CCOWdataItem5: IContextItem; //CCOW Cname: string; begin if Contextor <> nil then begin try //Part 1 Contextor.StartContextChange; //Part 2 Set the new proposed context data CCOWdata := CoContextItemCollection.Create; CCOWdataItem1 := CoContextItem.Create; Cname := CCOW_LOGON_ID; CCOWdataItem1.Name := Cname; CCOWdataItem1.Value := domain; CCOWData.Add(CCOWdataItem1); CCOWdataItem2 := CoContextItem.Create; Cname := CCOW_LOGON_TOKEN; CCOWdataItem2.Name := Cname; CCOWdataItem2.Value := token; CCOWdata.Add(CCOWdataItem2); CCOWdataItem3 := CoContextItem.Create; Cname := CCOW_LOGON_NAME; CCOWdataItem3.Name := Cname; CCOWdataItem3.Value := Uname; CCOWdata.Add(CCOWdataItem3); // CCOWdataItem4 := CoContextItem.Create; Cname := CCOW_LOGON_VPID; CCOWdataItem4.Name := Cname; CCOWdataItem4.Value := Vpid; CCOWdata.Add(CCOWdataItem4); // CCOWdataItem5 := CoContextItem.Create; Cname := CCOW_USER_NAME; CCOWdataItem5.Name := Cname; CCOWdataItem5.Value := Uname; CCOWdata.Add(CCOWdataItem5); //Part 3 Make change Contextor.EndContextChange(true, CCOWdata); //We don't need to check CCOWresponce finally end; //try end; //if end; //Get Token from CCOW context function TRPCBroker.GetCCOWtoken(Contextor: TContextorControl): string; var CCOWdataItem1: IContextItem; //CCOW CCOWcontextItem: IContextItemCollection; //CCOW name: string; begin result := ''; name := CCOW_LOGON_TOKEN; if (Contextor <> nil) then try CCOWcontextItem := Contextor.CurrentContext; //See if context contains the ID item CCOWdataItem1 := CCOWcontextItem.Present(name); if (CCOWdataItem1 <> nil) then //1 begin result := CCOWdataItem1.Value; if not (result = '') then FWasUserDefined := True; end; FCCOWLogonIDName := CCOW_LOGON_ID; FCCOWLogonName := CCOW_LOGON_NAME; FCCOWLogonVpid := CCOW_LOGON_VPID; CCOWdataItem1 := CCOWcontextItem.Present(CCOW_LOGON_ID); if CCOWdataItem1 <> nil then FCCOWLogonIdValue := CCOWdataItem1.Value; CCOWdataItem1 := CCOWcontextItem.Present(CCOW_LOGON_NAME); if CCOWdataItem1 <> nil then FCCOWLogonNameValue := CCOWdataItem1.Value; CCOWdataItem1 := CCOWcontextItem.Present(CCOW_LOGON_VPID); if CCOWdataItem1 <> nil then FCCOWLogonVpidValue := CCOWdataItem1.Value; finally end; //try end; //Get Name from CCOW context function TRPCBroker.GetCCOWduz(Contextor: TContextorControl): string; var CCOWdataItem1: IContextItem; //CCOW CCOWcontextItem: IContextItemCollection; //CCOW name: string; begin result := ''; name := CCOW_LOGON_ID; if (Contextor <> nil) then try CCOWcontextItem := Contextor.CurrentContext; //See if context contains the ID item CCOWdataItem1 := CCOWcontextItem.Present(name); if (CCOWdataItem1 <> nil) then //1 begin result := CCOWdataItem1.Value; if result <> '' then FWasUserDefined := True; end; finally end; //try end; function TRPCBroker.IsUserContextPending(aContextItemCollection: IContextItemCollection): Boolean; var CCOWdataItem1: IContextItem; //CCOW Val1: String; begin result := false; if WasUserDefined() then // indicates data was defined begin Val1 := ''; // look for any USER Context items defined result := True; // CCOWdataItem1 := aContextItemCollection.Present(CCOW_LOGON_ID); if CCOWdataItem1 <> nil then if not (CCOWdataItem1.Value = FCCOWLogonIDValue) then Val1 := '^' + CCOWdataItem1.Value; // CCOWdataItem1 := aContextItemCollection.Present(CCOW_LOGON_NAME); if CCOWdataItem1 <> nil then if not (CCOWdataItem1.Value = FCCOWLogonNameValue) then Val1 := Val1 + '^' + CCOWdataItem1.Value; // CCOWdataItem1 := aContextItemCollection.Present(CCOW_LOGON_VPID); if CCOWdataItem1 <> nil then if not (CCOWdataItem1.Value = FCCOWLogonVpidValue) then Val1 := Val1 + '^' + CCOWdataItem1.Value; // CCOWdataItem1 := aContextItemCollection.Present(CCOW_USER_NAME); if CCOWdataItem1 <> nil then if not (CCOWdataItem1.Value = user.Name) then Val1 := Val1 + '^' + CCOWdataItem1.Value; // if Val1 = '' then // nothing defined or all matches, so not user context change result := False; end; end; {* procedure CheckSSH was extracted to remove duplicate code in the SetConnected method of Trpcb and derived classes *} procedure TRpcBroker.CheckSSH; var ParamNum: Integer; ParamVal: String; ParamValNormal: String; begin ParamNum := 1; while (not (ParamStr(ParamNum) = '')) do begin ParamValNormal := ParamStr(ParamNum); ParamVal := UpperCase(ParamValNormal); // check for command line specifiction of connection // method if not set as a property if FUseSecureConnection = secureNone then begin if ParamVal = 'SSH' then FUseSecureConnection := secureAttachmate; if ParamVal = 'PLINK' then FUseSecureConnection := securePlink; end; // check for SSH specifications on command line if Pos('SSHPORT=',ParamVal) = 1 then FSSHPort := Copy(ParamVal,9,Length(ParamVal)); if Pos('SSHUSER=',ParamVal) = 1 then FSSHUser := Copy(ParamValNormal,9,Length(ParamVal)); if Pos('SSHPW=',ParamVal) = 1 then FSSHpw := Copy(ParamValNormal,7,Length(ParamVal)); if ParamVal = 'SSHHIDE' then FSSHhide := true; ParamNum := ParamNum + 1; end; end; function TRPCBroker.getSSHUsername: string; var UsernameEntry: TSSHUsername; begin UsernameEntry := TSSHUsername.Create(Self); UsernameEntry.ShowModal; Result := UsernameEntry.Edit1.Text; UsernameEntry.Free; end; function TRPCBroker.getSSHPassWord: string; var PasswordEntry: TfPlinkPassword; begin PasswordEntry := TfPlinkPassword.Create(Self); PasswordEntry.ShowModal; Result := PasswordEntry.Edit1.Text; PasswordEntry.Free; end; function TRPCBroker.StartSecureConnection(var PseudoServer, PseudoPort: String): Boolean; var CmndLine: String; begin // PseudoPort := NewSocket(); PseudoPort := FSSHPort; if FSSHPort = '' then PseudoPort := IntToStr(ListenerPort); PseudoServer := '127.0.0.1'; if (FSSHUser = '') then begin FSSHUser := getSSHUsername; end; if FUseSecureConnection = secureAttachmate then begin CmndLine := 'SSH2 -L '+PseudoPort+':'+FServer+':'+IntToStr(ListenerPort)+' -S -o "TryEmptyPassword yes" -o "MACs=hmac-sha1" -o "FipsMode yes" -o "StrictHostKeyChecking no" -o "connectionReuse no" '+FSSHUser+'@'+Server; end; if FUseSecureConnection = securePlink then begin if FSSHpw = '' then begin FSSHpw := getSSHPassWord end; CmndLine := 'plink.exe -L '+PseudoPort // -v +':'+PseudoServer+':'+ IntToStr(ListenerPort)+' '+FSSHUser+'@'+FServer +' -pw '+ FSSHpw; // IntToStr(ListenerPort)+' '+FSSHUser+'@'+FServer+' -pw 914Qemu5'; end; if FSSHhide then StartProgSLogin(CmndLine, nil, SW_HIDE) else StartProgSLogin(CmndLine, nil, SW_SHOWMINIMIZED); Sleep(5000); result := true; end; end.