source: cprs/branches/GUI-config/BDK32/Source/CCOWRPCBroker.pas@ 525

Last change on this file since 525 was 476, checked in by Kevin Toppenberg, 17 years ago

New WorldVistA Config Utility
File size: 20.5 KB
RevLine 
[476]1{ **************************************************************
2 Package: XWB - Kernel RPCBroker
3 Date Created: Sept 18, 1997 (Version 1.1)
4 Site Name: Oakland, OI Field Office, Dept of Veteran Affairs
5 Developers: Danila Manapsal, Don Craven, Joel Ivey
6 Description: Contains TRPCBroker and related components.
7 Current Release: Version 1.1 Patch 40 (January 7, 2005)
8*************************************************************** }
9
10{**************************************************
11This is the hierarchy of things:
12 TRPCBroker contains
13 TParams, which contains
14 array of TParamRecord each of which contains
15 TMult
16
17v1.1*4 Silent Login changes (DCM) 10/22/98
18
191.1*6 Polling to support terminating arphaned server jobs. (P6)
20 == DPC 4/99
21
221.1*8 Check for Multi-Division users. (P8) - REM 7/13/99
23
241.1*13 More silent login code; deleted obsolete lines (DCM) 9/10/99 // p13
25LAST UPDATED: 5/24/2001 // p13 JLI
26
271.1*31 Added new read only property BrokerVersion to TRPCBroker which
28 should contain the version number for the RPCBroker
29 (or SharedRPCBroker) in use.
30**************************************************}
31unit CCOWRPCBroker;
32
33interface
34
35{$I IISBase.inc}
36
37uses
38 {Delphi standard}
39 Classes, Controls, Dialogs, {DsgnIntf,} Forms, Graphics, Messages, SysUtils,
40 WinProcs, WinTypes, Windows,
41 extctrls, {P6}
42 {VA}
43 XWBut1, {RpcbEdtr,} MFunStr, Hash,
44 ComObj, ActiveX, OleCtrls, trpcb,
45 VERGENCECONTEXTORLib_TLB;
46
47const
48 NoMore: boolean = False;
49 MIN_RPCTIMELIMIT: integer = 30;
50 CURRENT_RPC_VERSION: String = 'XWB*1.1*36T1';
51
52type
53
54TCCOWRPCBroker = class(TRPCBroker)
55private
56protected
57 FCCOWLogonIDName: String;
58 FCCOWLogonIDValue: String;
59 FCCOWLogonName: String;
60 FCCOWLogonNameValue: String;
61 FContextor: TContextorControl; //CCOW
62 FCCOWtoken: string; //CCOW
63 FVistaDomain: String;
64 FCCOWLogonVpid: String;
65 FCCOWLogonVpidValue: String;
66 FWasUserDefined: Boolean;
67 procedure SetConnected(Value: Boolean); override;
68 function GetCCOWHandle(ConnectedBroker: TCCOWRPCBroker): string;
69 procedure CCOWsetUser(Uname, token, Domain, Vpid: string; Contextor:
70 TContextorControl);
71 function GetCCOWduz( Contextor: TContextorControl): string;
72public
73 function GetCCOWtoken(Contextor: TContextorControl): string;
74 function IsUserCleared: Boolean;
75 function WasUserDefined: Boolean;
76 function IsUserContextPending(aContextItemCollection: IContextItemCollection):
77 Boolean;
78 property Contextor: TContextorControl
79 read Fcontextor write FContextor; //CCOW
80 property CCOWLogonIDName: String read FCCOWLogonIDName;
81 property CCOWLogonIDValue: String read FCCOWLogonIDValue;
82 property CCOWLogonName: String read FCCOWLogonName;
83 property CCOWLogonNameValue: String read FCCOWLogonNameValue;
84 property CCOWLogonVpid: String read FCCOWLogonVpid;
85 property CCOWLogonVpidValue: String read FCCOWLogonVpidValue;
86published
87 property Connected: boolean read FConnected write SetConnected;
88 end;
89
90procedure AuthenticateUser(ConnectingBroker: TCCOWRPCBroker);
91
92implementation
93
94uses
95 Loginfrm, RpcbErr, WSockc, SelDiv{p8}, RpcSLogin{p13}, fRPCBErrMsg,
96 CCOW_const;
97
98var
99 CCOWToken: String;
100 Domain: String;
101 PassCode1: String;
102 PassCode2: String;
103
104
105{--------------------- TCCOWRPCBroker.SetConnected --------------------
106------------------------------------------------------------------}
107procedure TCCOWRPCBroker.SetConnected(Value: Boolean);
108var
109 BrokerDir, Str1, Str2, Str3 :string;
110 RPCBContextor: TContextorControl;
111begin
112 RPCBError := '';
113 Login.ErrorText := '';
114 if (Connected <> Value) and not(csReading in ComponentState) then begin
115 if Value and (FConnecting <> Value) then begin {connect}
116 FSocket := ExistingSocket(Self);
117 FConnecting := True; // FConnected := True;
118 try
119 if FSocket = 0 then
120 begin
121 {Execute Client Agent from directory in Registry.}
122 BrokerDir := ReadRegData(HKLM, REG_BROKER, 'BrokerDr');
123 if BrokerDir <> '' then
124 ProcessExecute(BrokerDir + '\ClAgent.Exe', sw_ShowNoActivate)
125 else
126 ProcessExecute('ClAgent.Exe', sw_ShowNoActivate);
127 if DebugMode and (not OldConnectionOnly) then
128 begin
129 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;
130 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;
131 Str3 := '4. Connect the client application using the port number entered in Step #3.';
132 ShowMessage(Str1 + Str2 + Str3);
133 end;
134 TXWBWinsock(XWBWinsock).IsBackwardsCompatible := IsBackwardCompatibleConnection;
135 TXWBWinsock(XWBWinsock).OldConnectionOnly := OldConnectionOnly;
136 FSocket := TXWBWinsock(XWBWinsock).NetworkConnect(DebugMode, FServer,
137 ListenerPort, FRPCTimeLimit);
138 AuthenticateUser(Self);
139 StoreConnection(Self); //MUST store connection before CreateContext()
140 //CCOW start
141 if (FContextor <> nil) and (length(CCOWtoken) = 0) then
142 begin
143 //Get new CCOW token
144 CCOWToken := GetCCOWHandle(Self);
145 if Length(CCOWToken) > 0 then
146 begin
147 try
148 RPCBContextor := TContextorControl.Create(Application);
149 RPCBContextor.Run('BrokerLoginModule#', PassCode1+PassCode2, TRUE, '*');
150 CCOWsetUser(user.name, CCOWToken, Domain, user.Vpid, RPCBContextor); //Clear token
151 FCCOWLogonIDName := CCOW_LOGON_ID;
152 FCCOWLogonIdValue := Domain;
153 FCCOWLogonName := CCOW_LOGON_NAME;
154 FCCOWLogonNameValue := user.name;
155 if user.name <> '' then
156 FWasUserDefined := True;
157 FCCOWLogonVpid := CCOW_LOGON_VPID;
158 FCCOWLogonVpidValue := user.Vpid;
159 RPCBContextor.Free;
160 RPCBContextor := nil;
161 except
162 ShowMessage('Problem with Contextor.Run');
163 FreeAndNil(RPCBContextor);
164 end;
165 end; // if Length(CCOWToken) > 0
166 end; //if
167 //CCOW end
168 FPulse.Enabled := True; //P6 Start heartbeat.
169 CreateContext(''); //Closes XUS SIGNON context.
170 end
171 else
172 begin //p13
173 StoreConnection(Self);
174 FPulse.Enabled := True; //p13
175 end; //p13
176 FConnected := True; // jli mod 12/17/01
177 FConnecting := False;
178 except
179 on E: EBrokerError do begin
180 if E.Code = XWB_BadSignOn then
181 TXWBWinsock(XWBWinsock).NetworkDisconnect(FSocket);
182 FSocket := 0;
183 FConnected := False;
184 FConnecting := False;
185 FRPCBError := E.Message; // p13 handle errors as specified
186 if Login.ErrorText <> '' then
187 FRPCBError := E.Message + chr(10) + Login.ErrorText;
188 if Assigned(FOnRPCBFailure) then // p13
189 FOnRPCBFailure(Self) // p13
190 else if ShowErrorMsgs = semRaise then
191 Raise; // p13
192// raise; {this is where I would do OnNetError}
193 end{on};
194 end{try};
195 end{if}
196 else if not Value then
197 begin //p13
198 FConnected := False; //p13
199 FPulse.Enabled := False; //p13
200 if RemoveConnection(Self) = NoMore then begin
201 {FPulse.Enabled := False; ///P6;p13 }
202 TXWBWinsock(XWBWinsock).NetworkDisconnect(Socket); {actually disconnect from server}
203 FSocket := 0; {store internal}
204 //FConnected := False; //p13
205 end{if};
206 end; {else}
207 end{if};
208end;
209
210function TCCOWRPCBroker.WasUserDefined: Boolean;
211begin
212 Result := FWasUserDefined;
213end;
214
215function TCCOWRPCBroker.IsUserCleared: Boolean;
216var
217 CCOWcontextItem: IContextItemCollection; //CCOW
218 CCOWdataItem1: IContextItem; //CCOW
219 Name: String;
220begin
221 Result := False;
222 Name := CCOW_LOGON_ID;
223 if (Contextor <> nil) then
224 try
225 //See if context contains the ID item
226 CCOWcontextItem := Contextor.CurrentContext;
227 CCOWDataItem1 := CCowContextItem.Present(Name);
228 if (CCOWdataItem1 <> nil) then //1
229 begin
230 If CCOWdataItem1.Value = '' then
231 Result := True
232 else
233 FWasUserDefined := True;
234 end
235 else
236 Result := True;
237 finally
238 end; //try
239end;
240
241{------------------------ AuthenticateUser ------------------------
242------------------------------------------------------------------}
243procedure AuthenticateUser(ConnectingBroker: TCCOWRPCBroker);
244var
245 SaveClearParmeters, SaveClearResults: boolean;
246 SaveParam: TParams;
247 SaveRemoteProcedure, SaveRpcVersion: string;
248 SaveResults: TStrings;
249 blnSignedOn: boolean;
250 SaveKernelLogin: boolean;
251 SaveVistaLogin: TVistaLogin;
252 OldExceptionHandler: TExceptionEvent;
253 OldHandle: THandle;
254begin
255 With ConnectingBroker do
256 begin
257 SaveParam := TParams.Create(nil);
258 SaveParam.Assign(Param); //save off settings
259 SaveRemoteProcedure := RemoteProcedure;
260 SaveRpcVersion := RpcVersion;
261 SaveResults := Results;
262 SaveClearParmeters := ClearParameters;
263 SaveClearResults := ClearResults;
264 ClearParameters := True; //set'em as I need'em
265 ClearResults := True;
266 SaveKernelLogin := KernelLogin; // p13
267 SaveVistaLogin := Login; // p13
268 end;
269
270 blnSignedOn := False; //initialize to bad sign-on
271
272 if ConnectingBroker.AccessVerifyCodes <> '' then // p13 handle as AVCode single signon
273 begin
274 ConnectingBroker.Login.AccessCode := Piece(ConnectingBroker.AccessVerifyCodes, ';', 1);
275 ConnectingBroker.Login.VerifyCode := Piece(ConnectingBroker.AccessVerifyCodes, ';', 2);
276 ConnectingBroker.Login.Mode := lmAVCodes;
277 ConnectingBroker.KernelLogIn := False;
278 end;
279
280 //CCOW start
281 if ConnectingBroker.KernelLogIn and (not (ConnectingBroker.Contextor = nil)) then
282 begin
283 CCOWtoken := ConnectingBroker.GetCCOWtoken(ConnectingBroker.Contextor);
284 if length(CCOWtoken)>0 then
285 begin
286 ConnectingBroker.FKernelLogIn := false;
287 ConnectingBroker.Login.Mode := lmAppHandle;
288 ConnectingBroker.Login.LogInHandle := CCOWtoken;
289 end;
290 end;
291 //CCOW end
292 //CCOW Start // p13 following section for silent signon
293 if not ConnectingBroker.FKernelLogIn then
294 if ConnectingBroker.FLogin <> nil then //the user. vistalogin contains login info
295 begin
296 blnsignedon := SilentLogin(ConnectingBroker); // RpcSLogin unit
297 if not blnSignedOn then
298 begin //Switch back to Kernel Login
299 ConnectingBroker.FKernelLogIn := true;
300 ConnectingBroker.Login.Mode := lmAVCodes;
301 end;
302 end;
303 //CCOW end
304
305 if ConnectingBroker.FKernelLogIn then
306 begin //p13
307 if Assigned(Application.OnException) then
308 OldExceptionHandler := Application.OnException
309 else
310 OldExceptionHandler := nil;
311 Application.OnException := TfrmErrMsg.RPCBShowException;
312 frmSignon := TfrmSignon.Create(Application);
313 try
314
315 // ShowApplicationAndFocusOK(Application);
316 OldHandle := GetForegroundWindow;
317 SetForegroundWindow(frmSignon.Handle);
318 PrepareSignonForm(ConnectingBroker);
319 if SetUpSignOn then //SetUpSignOn in loginfrm unit.
320 begin //True if signon needed
321
322 if frmSignOn.lblServer.Caption <> '' then
323 begin
324 frmSignOn.ShowModal; //do interactive logon // p13
325 if frmSignOn.Tag = 1 then //Tag=1 for good logon
326 blnSignedOn := True; //Successfull logon
327 end
328 end
329 else //False when no logon needed
330 blnSignedOn := NoSignOnNeeded; //Returns True always (for now!)
331 if blnSignedOn then //P6 If logged on, retrieve user info.
332 begin
333 GetBrokerInfo(ConnectingBroker);
334 if not SelDiv.ChooseDiv('',ConnectingBroker) then
335 begin
336 blnSignedOn := False;//P8
337 {Select division if multi-division user. First parameter is 'userid'
338 (DUZ or username) for future use. (P8)}
339 ConnectingBroker.Login.ErrorText := 'Failed to select Division'; // p13 set some text indicating problem
340 end;
341 end;
342 SetForegroundWindow(OldHandle);
343 finally
344 frmSignon.Free;
345// frmSignon.Release; //get rid of signon form
346
347// if ConnectingBroker.Owner is TForm then
348// SetForegroundWindow(TForm(ConnectingBroker.Owner).Handle)
349// else
350// SetForegroundWindow(ActiveWindow);
351 ShowApplicationAndFocusOK(Application);
352 end ; //try
353 if Assigned(OldExceptionHandler) then
354 Application.OnException := OldExceptionHandler;
355 end; //if kernellogin
356 // p13 following section for silent signon
357 if (not ConnectingBroker.KernelLogIn) and (not blnsignedon) then // was doing the signon twice if already true
358 if ConnectingBroker.Login <> nil then //the user. vistalogin contains login info
359 blnsignedon := SilentLogin(ConnectingBroker); // RpcSLogin unit
360 if not blnsignedon then
361 begin
362// ConnectingBroker.Login.FailedLogin(ConnectingBroker.Login);
363 TXWBWinsock(ConnectingBroker.XWBWinsock).NetworkDisconnect(ConnectingBroker.Socket);
364 end
365 else
366 GetBrokerInfo(ConnectingBroker);
367
368 //reset the Broker
369 with ConnectingBroker do
370 begin
371 ClearParameters := SaveClearParmeters;
372 ClearResults := SaveClearResults;
373 Param.Assign(SaveParam); //restore settings
374 SaveParam.Free;
375 RemoteProcedure := SaveRemoteProcedure;
376 RpcVersion := SaveRpcVersion;
377 Results := SaveResults;
378 FKernelLogin := SaveKernelLogin; // p13
379 FLogin := SaveVistaLogin; // p13
380 end;
381
382 if not blnSignedOn then //Flag for unsuccessful signon.
383 TXWBWinsock(ConnectingBroker.XWBWinsock).NetError('',XWB_BadSignOn); //Will raise error.
384
385end;
386
387{----------------------- GetCCOWHandle --------------------------
388Private function to return a special CCOW Handle from the server
389which is set into the CCOW context.
390The Broker of a new application can get the CCOWHandle from the context
391and use it to do a ImAPPHandle Sign-on.
392----------------------------------------------------------------}
393function TCCOWRPCBroker.GetCCOWHandle(ConnectedBroker : TCCOWRPCBroker): String; // p13
394begin
395 Result := '';
396 with ConnectedBroker do
397 try // to permit it to work correctly if CCOW is not installed on the server.
398 begin
399 RemoteProcedure := 'XUS GET CCOW TOKEN';
400 Call;
401 Result := Results[0];
402 Domain := Results[1];
403 RemoteProcedure := 'XUS CCOW VAULT PARAM';
404 Call;
405 PassCode1 := Results[0];
406 PassCode2 := Results[1];
407 end;
408 except
409 Result := '';
410 end;
411end;
412
413//CCOW start
414procedure TCCOWRPCBroker.CCOWsetUser(Uname, token, Domain, Vpid: string; Contextor:
415 TContextorControl);
416var
417 CCOWdata: IContextItemCollection; //CCOW
418 CCOWdataItem1,CCOWdataItem2,CCOWdataItem3: IContextItem;
419 CCOWdataItem4,CCOWdataItem5: IContextItem; //CCOW
420 Cname: string;
421begin
422 if Contextor <> nil then
423 begin
424 try
425 //Part 1
426 Contextor.StartContextChange;
427 //Part 2 Set the new proposed context data
428 CCOWdata := CoContextItemCollection.Create;
429 CCOWdataItem1 := CoContextItem.Create;
430 Cname := CCOW_LOGON_ID;
431 CCOWdataItem1.Name := Cname;
432 CCOWdataItem1.Value := domain;
433 CCOWData.Add(CCOWdataItem1);
434 CCOWdataItem2 := CoContextItem.Create;
435 Cname := CCOW_LOGON_TOKEN;
436 CCOWdataItem2.Name := Cname;
437 CCOWdataItem2.Value := token;
438 CCOWdata.Add(CCOWdataItem2);
439 CCOWdataItem3 := CoContextItem.Create;
440 Cname := CCOW_LOGON_NAME;
441 CCOWdataItem3.Name := Cname;
442 CCOWdataItem3.Value := Uname;
443 CCOWdata.Add(CCOWdataItem3);
444 //
445 CCOWdataItem4 := CoContextItem.Create;
446 Cname := CCOW_LOGON_VPID;
447 CCOWdataItem4.Name := Cname;
448 CCOWdataItem4.Value := Vpid;
449 CCOWdata.Add(CCOWdataItem4);
450 //
451 CCOWdataItem5 := CoContextItem.Create;
452 Cname := CCOW_USER_NAME;
453 CCOWdataItem5.Name := Cname;
454 CCOWdataItem5.Value := Uname;
455 CCOWdata.Add(CCOWdataItem5);
456 //Part 3 Make change
457 Contextor.EndContextChange(true, CCOWdata);
458 //We don't need to check CCOWresponce
459 finally
460 end; //try
461 end; //if
462end;
463
464//Get Token from CCOW context
465function TCCOWRPCBroker.GetCCOWtoken(Contextor: TContextorControl): string;
466var
467 CCOWdataItem1: IContextItem; //CCOW
468 CCOWcontextItem: IContextItemCollection; //CCOW
469 name: string;
470begin
471 result := '';
472 name := CCOW_LOGON_TOKEN;
473 if (Contextor <> nil) then
474 try
475 CCOWcontextItem := Contextor.CurrentContext;
476 //See if context contains the ID item
477 CCOWdataItem1 := CCOWcontextItem.Present(name);
478 if (CCOWdataItem1 <> nil) then //1
479 begin
480 result := CCOWdataItem1.Value;
481 if not (result = '') then
482 FWasUserDefined := True;
483 end;
484 FCCOWLogonIDName := CCOW_LOGON_ID;
485 FCCOWLogonName := CCOW_LOGON_NAME;
486 FCCOWLogonVpid := CCOW_LOGON_VPID;
487 CCOWdataItem1 := CCOWcontextItem.Present(CCOW_LOGON_ID);
488 if CCOWdataItem1 <> nil then
489 FCCOWLogonIdValue := CCOWdataItem1.Value;
490 CCOWdataItem1 := CCOWcontextItem.Present(CCOW_LOGON_NAME);
491 if CCOWdataItem1 <> nil then
492 FCCOWLogonNameValue := CCOWdataItem1.Value;
493 CCOWdataItem1 := CCOWcontextItem.Present(CCOW_LOGON_VPID);
494 if CCOWdataItem1 <> nil then
495 FCCOWLogonVpidValue := CCOWdataItem1.Value;
496 finally
497 end; //try
498end;
499
500//Get Name from CCOW context
501function TCCOWRPCBroker.GetCCOWduz(Contextor: TContextorControl): string;
502var
503 CCOWdataItem1: IContextItem; //CCOW
504 CCOWcontextItem: IContextItemCollection; //CCOW
505 name: string;
506begin
507 result := '';
508 name := CCOW_LOGON_ID;
509 if (Contextor <> nil) then
510 try
511 CCOWcontextItem := Contextor.CurrentContext;
512 //See if context contains the ID item
513 CCOWdataItem1 := CCOWcontextItem.Present(name);
514 if (CCOWdataItem1 <> nil) then //1
515 begin
516 result := CCOWdataItem1.Value;
517 if result <> '' then
518 FWasUserDefined := True;
519 end;
520 finally
521 end; //try
522end;
523
524function TCCOWRPCBroker.IsUserContextPending(aContextItemCollection:
525 IContextItemCollection): Boolean;
526var
527 CCOWdataItem1: IContextItem; //CCOW
528 Val1: String;
529begin
530 result := false;
531 if WasUserDefined() then // indicates data was defined
532 begin
533 Val1 := ''; // look for any USER Context items defined
534 result := True;
535 //
536 CCOWdataItem1 := aContextItemCollection.Present(CCOW_LOGON_ID);
537 if (CCOWdataItem1 <> nil) then //1
538 Val1 := CCOWdataItem1.Value;
539 //
540 CCOWdataItem1 := aContextItemCollection.Present(CCOW_LOGON_ID);
541 if CCOWdataItem1 <> nil then
542 Val1 := Val1 + '^' + CCOWdataItem1.Value;
543 //
544 CCOWdataItem1 := aContextItemCollection.Present(CCOW_LOGON_NAME);
545 if CCOWdataItem1 <> nil then
546 Val1 := Val1 + '^' + CCOWdataItem1.Value;
547 //
548 CCOWdataItem1 := aContextItemCollection.Present(CCOW_LOGON_VPID);
549 if CCOWdataItem1 <> nil then
550 Val1 := Val1 + '^' + CCOWdataItem1.Value;
551 //
552 CCOWdataItem1 := aContextItemCollection.Present(CCOW_USER_NAME);
553 if CCOWdataItem1 <> nil then
554 Val1 := Val1 + '^' + CCOWdataItem1.Value;
555 //
556 if Val1 <> '' then // something defined, so not user context change
557 result := False;
558 end;
559end;
560
561end.
562
Note: See TracBrowser for help on using the repository browser.