VistA-cprs/BDK32/Source/CCOWRPCBroker.pas

563 lines
20 KiB
Plaintext

{ **************************************************************
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 40 (January 7, 2005)
*************************************************************** }
{**************************************************
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 CCOWRPCBroker;
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,
ComObj, ActiveX, OleCtrls, trpcb,
VERGENCECONTEXTORLib_TLB;
const
NoMore: boolean = False;
MIN_RPCTIMELIMIT: integer = 30;
CURRENT_RPC_VERSION: String = 'XWB*1.1*36T1';
type
TCCOWRPCBroker = class(TRPCBroker)
private
protected
FCCOWLogonIDName: String;
FCCOWLogonIDValue: String;
FCCOWLogonName: String;
FCCOWLogonNameValue: String;
FContextor: TContextorControl; //CCOW
FCCOWtoken: string; //CCOW
FVistaDomain: String;
FCCOWLogonVpid: String;
FCCOWLogonVpidValue: String;
FWasUserDefined: Boolean;
procedure SetConnected(Value: Boolean); override;
function GetCCOWHandle(ConnectedBroker: TCCOWRPCBroker): string;
procedure CCOWsetUser(Uname, token, Domain, Vpid: string; Contextor:
TContextorControl);
function GetCCOWduz( Contextor: TContextorControl): string;
public
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;
published
property Connected: boolean read FConnected write SetConnected;
end;
procedure AuthenticateUser(ConnectingBroker: TCCOWRPCBroker);
implementation
uses
Loginfrm, RpcbErr, WSockc, SelDiv{p8}, RpcSLogin{p13}, fRPCBErrMsg,
CCOW_const;
var
CCOWToken: String;
Domain: String;
PassCode1: String;
PassCode2: String;
{--------------------- TCCOWRPCBroker.SetConnected --------------------
------------------------------------------------------------------}
procedure TCCOWRPCBroker.SetConnected(Value: Boolean);
var
BrokerDir, Str1, Str2, Str3 :string;
RPCBContextor: TContextorControl;
begin
RPCBError := '';
Login.ErrorText := '';
if (Connected <> Value) and not(csReading in ComponentState) then begin
if Value and (FConnecting <> Value) then begin {connect}
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 FOR UCX OR NON-CALLBACK CONNECTIONS 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;
TXWBWinsock(XWBWinsock).IsBackwardsCompatible := IsBackwardCompatibleConnection;
TXWBWinsock(XWBWinsock).OldConnectionOnly := OldConnectionOnly;
FSocket := TXWBWinsock(XWBWinsock).NetworkConnect(DebugMode, FServer,
ListenerPort, FRPCTimeLimit);
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;
except
on E: EBrokerError do begin
if E.Code = XWB_BadSignOn then
TXWBWinsock(XWBWinsock).NetworkDisconnect(FSocket);
FSocket := 0;
FConnected := False;
FConnecting := False;
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
end{if};
end; {else}
end{if};
end;
function TCCOWRPCBroker.WasUserDefined: Boolean;
begin
Result := FWasUserDefined;
end;
function TCCOWRPCBroker.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;
{------------------------ AuthenticateUser ------------------------
------------------------------------------------------------------}
procedure AuthenticateUser(ConnectingBroker: TCCOWRPCBroker);
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 := KernelLogin; // p13
SaveVistaLogin := Login; // p13
end;
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.KernelLogIn := 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
//CCOW Start // p13 following section for silent signon
if not ConnectingBroker.FKernelLogIn then
if ConnectingBroker.FLogin <> nil then //the user. vistalogin contains login info
begin
blnsignedon := SilentLogin(ConnectingBroker); // RpcSLogin unit
if not blnSignedOn then
begin //Switch back to Kernel Login
ConnectingBroker.FKernelLogIn := true;
ConnectingBroker.Login.Mode := lmAVCodes;
end;
end;
//CCOW end
if ConnectingBroker.FKernelLogIn then
begin //p13
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.KernelLogIn) and (not blnsignedon) then // was doing the signon twice if already true
if ConnectingBroker.Login <> nil then //the user. vistalogin contains login info
blnsignedon := SilentLogin(ConnectingBroker); // RpcSLogin unit
if not blnsignedon then
begin
// ConnectingBroker.Login.FailedLogin(ConnectingBroker.Login);
TXWBWinsock(ConnectingBroker.XWBWinsock).NetworkDisconnect(ConnectingBroker.Socket);
end
else
GetBrokerInfo(ConnectingBroker);
//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;
if not blnSignedOn then //Flag for unsuccessful signon.
TXWBWinsock(ConnectingBroker.XWBWinsock).NetError('',XWB_BadSignOn); //Will raise error.
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 TCCOWRPCBroker.GetCCOWHandle(ConnectedBroker : TCCOWRPCBroker): 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 TCCOWRPCBroker.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 TCCOWRPCBroker.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 TCCOWRPCBroker.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 TCCOWRPCBroker.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 //1
Val1 := CCOWdataItem1.Value;
//
CCOWdataItem1 := aContextItemCollection.Present(CCOW_LOGON_ID);
if CCOWdataItem1 <> nil then
Val1 := Val1 + '^' + CCOWdataItem1.Value;
//
CCOWdataItem1 := aContextItemCollection.Present(CCOW_LOGON_NAME);
if CCOWdataItem1 <> nil then
Val1 := Val1 + '^' + CCOWdataItem1.Value;
//
CCOWdataItem1 := aContextItemCollection.Present(CCOW_LOGON_VPID);
if CCOWdataItem1 <> nil then
Val1 := Val1 + '^' + CCOWdataItem1.Value;
//
CCOWdataItem1 := aContextItemCollection.Present(CCOW_USER_NAME);
if CCOWdataItem1 <> nil then
Val1 := Val1 + '^' + CCOWdataItem1.Value;
//
if Val1 <> '' then // something defined, so not user context change
result := False;
end;
end;
end.