source: WorldVistAEHR/trunk/r/VISTALINK_SECURITY-XOBS/XOBSRA.m@ 1800

Last change on this file since 1800 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 8.6 KB
RevLine 
[613]1XOBSRA ;mjk,esd/alb - VistALink Reauthentication Code ; 05/22/2003 07:00
2 ;;1.5;VistALink Security;;Sep 09, 2005
3 ;;Foundations Toolbox Release v1.5 [Build: 1.5.0.026]
4 ;
5 QUIT
6 ;
7 ; ------------------------------------------------------------------------
8 ; RPC Server: Reauthentication based on VPID, DUZ, and AV
9 ; ------------------------------------------------------------------------
10 ;
11SETUPDUZ() ; -- get DUZ context and division
12 ;
13 NEW XOBERR,XOBID,XOBTYPE
14 SET (XOBERR,XOBID)=0
15 ;
16 ; -- if already authenticated quit
17 IF $GET(XOBDATA("XOB RPC","SECURITY","STATE"))="authenticated" GOTO SUDQ
18 ;
19 ; -- switch to null device
20 DO NULL
21 ; -- initialize partition
22 DO INIT
23 ;
24 ; -- check if logons are enabled
25 SET XOBERR=$$LOGINH()
26 IF XOBERR DO SOCKET GOTO SUDQ
27 ;
28 ; -- reauthenticate user based on type
29 SET XOBTYPE=$GET(XOBDATA("XOB RPC","SECURITY","TYPE")),XOBTYPE=$$UP^XLFSTR(XOBTYPE)
30 IF XOBTYPE="DUZ"!(XOBTYPE="AV")!(XOBTYPE="VPID")!(XOBTYPE="CCOW")!(XOBTYPE="APPPROXY") DO
31 . DO @(XOBTYPE_"(.XOBID,.XOBERR)")
32 ELSE DO
33 . SET XOBERR=182301_U_XOBTYPE_U_" [Erroneous reauthentication type]"
34 ;
35 ; -- check division
36 IF XOBID SET XOBERR=$$DUZENV(XOBID,XOBTYPE)
37 ;
38 ; -- switch back to socket device
39 DO SOCKET
40SUDQ ;
41 ;LOG:: Log error in trap or elsewhere if appropriate. May want to log 'no match' event for security reasons.
42 IF 'XOBERR DO FINAL
43 QUIT XOBERR
44 ;
45NULL ; switch to null device
46 USE XOBNULL
47 QUIT
48 ;
49SOCKET ; -- switch back to socket device
50 ; -- empty write buffer of null device
51 USE XOBNULL SET DX=0,DY=0 XECUTE ^%ZOSF("XY")
52 ; -- reset to use tcp port device to send results
53 USE XOBPORT
54 QUIT
55 ;
56AV(XOBID,XOBERR) ; -- AV (SSO/UC KAAJEE) reauth type
57 ;
58 ; More checks performed here; assume this would be called ONCE when user authenticates
59 ; to application via KAAJEE or FatKAAT
60 ;
61 DO AV^XOBSRAKJ(.XOBID,.XOBERR)
62 QUIT
63 ;
64DUZ(XOBID,XOBERR) ; -- DUZ reauth type
65 ;
66 NEW XOBCTYPE
67 SET XOBCTYPE="DUZ"
68 SET XOBID=$GET(XOBDATA("XOB RPC","SECURITY","TYPE","VALUE"))
69 ;
70 ; Active user status check performed here; assume heavier-duty checks done by application
71 ; when user authenticated to application via KAAJEE, FatKAAT or equivalent.
72 ;
73 DO ACTUSR(.XOBID,.XOBERR,XOBCTYPE)
74 QUIT
75 ;
76VPID(XOBID,XOBERR) ; -- VPID reauth type
77 NEW VPID,XOBCTYPE
78 SET XOBID=0
79 SET XOBCTYPE="VPID"
80 ;
81 SET VPID=$GET(XOBDATA("XOB RPC","SECURITY","TYPE","VALUE"))
82 IF VPID]"" SET XOBID=$$IEN^XUPS(VPID)
83 ;
84 IF '+XOBID DO QUIT
85 . SET XOBERR=182301_U_XOBTYPE_U_"["_XOBCTYPE_" Value: '"_VPID_"']"
86 . SET XOBID=0
87 ;
88 ; Active user status check performed here; assume heavier-duty checks done by application
89 ; when user authenticated to application via KAAJEE, FatKAAT or equivalent.
90 ;
91 DO ACTUSR(.XOBID,.XOBERR,XOBCTYPE)
92 QUIT
93 ;
94APPPROXY(XOBID,XOBERR) ; -- application proxy reauth type
95 ;
96 NEW XOBANAME,XOBCTYPE
97 SET XOBID=0,XOBCTYPE="APPPROXY"
98 SET XOBANAME=$GET(XOBDATA("XOB RPC","SECURITY","TYPE","VALUE"))
99 ;
100 ; APFIND^XUSAP(name) -> returns ien^vpid
101 IF XOBANAME]"" SET XOBID=$PIECE($$APFIND^XUSAP(XOBANAME),U)
102 ; file #200 division mult checking not necessary for app proxy user
103 IF (+XOBID)<1 DO
104 . SET XOBERR=182307_U_XOBANAME_U,XOBID=0
105 QUIT
106 ;
107CCOW(XOBID,XOBERR) ; -- CCOW reauth type
108 ;
109 ; Very few checks performed here; assume heavier duty checks done by application when originally
110 ; authenticated and created Kernel CCOW token. User would need to be reauthenticated (and perform
111 ; heavier-duty checks) upon Kernel CCOW token expiration.
112 ;
113 DO CCOW^XOBSRAKJ(.XOBID,.XOBERR)
114 QUIT
115 ;
116ACTUSR(XOBID,XOBERR,XOBCTYPE) ; -- user active status check & error processing
117 ;
118 NEW XOBACTIV
119 SET XOBACTIV=0
120 SET XOBID=$GET(XOBID),XOBCTYPE=$GET(XOBCTYPE)
121 ;
122 ;-- returns active status indicator of user
123 SET XOBACTIV=$$ACTIVE^XUSER(XOBID)
124 IF +XOBACTIV<1 DO
125 . ;
126 . ;-- get dialog entry for error
127 . SET XOBERR=$$GETERR(XOBACTIV,XOBID,XOBCTYPE)
128 . SET XOBID=0
129 QUIT
130 ;
131DUZENV(XOBDUZ,XOBTYPE) ; -- build DUZ and check division
132 ;
133 ; QUIT 0 if OK, DialogErrorNumber^DialogErrorParameter1^... if bad
134 ;
135 NEW XOBDVARY,XOBDIV,XOBDIVEX,XOBDIVRQ,XOBDUZSV,XOBERR,XOBI,XOBOK
136 SET XOBOK=0,(XOBERR,XOBDIVEX)=""
137 ;
138 ; -- preserve previous DUZ value, restore if needed
139 MERGE XOBDUZSV=DUZ KILL DUZ
140 ;
141 ; -- set up info on passed in user
142 SET DUZ=XOBDUZ
143 SET XOBDIVRQ("STATIONNUMBER")=$GET(XOBDATA("XOB RPC","SECURITY","DIV"))
144 ;
145 DO ; checks
146 .;
147 .; -- if no division passed in
148 . IF XOBDIVRQ("STATIONNUMBER")']"" DO QUIT
149 . . SET XOBERR=182308_U_"no division passed"_U_XOBTYPE_U_XOBDUZ_U_"null"
150 . ;
151 . ; -- is division supported at the site?
152 . SET XOBDIVRQ("IEN")=$$SITECHK(XOBDIVRQ("STATIONNUMBER"))
153 . IF '+XOBDIVRQ("IEN") DO QUIT
154 . . SET XOBERR=182308_U_$P(XOBDIVRQ("IEN"),U,2)_U_XOBTYPE_U_XOBDUZ_U_XOBDIVRQ("STATIONNUMBER")
155 . . KILL XOBDIVRQ("IEN")
156 .;
157 .; -- build DUZ
158 . DO DUZ^XUP(DUZ)
159 .;
160 .; -- don't do user-based checks if reauth type is APPPROXY
161 .IF XOBTYPE="APPPROXY" SET XOBOK=1 QUIT
162 .;
163 .; -- do check for user-permitted divisions
164 . DO DIVGET^XUSRB2(.XOBDIV,DUZ)
165 .;
166 .; -- DIVGET^XUSRB2 return value: if no divisions or one (matching) division, it's good
167 . IF '$GET(XOBDIV(0)) DO QUIT
168 .. IF $GET(DUZ(2))=XOBDIVRQ("IEN") SET XOBOK=1 QUIT ; OK
169 ..;
170 ..; -- if got here, did not match division
171 .. SET XOBERR=182302_U_XOBTYPE_U_XOBDUZ_U_XOBDIVRQ("STATIONNUMBER")
172 .;
173 .; -- DIVGET^XUSRB2 return value: if >1 divisions to select, attempt to set DUZ(2) to div passed in
174 . DO DIVSET^XUSRB2(.XOBOK,"`"_XOBDIVRQ("IEN")) I 'XOBOK DO
175 .. SET XOBERR=182302_U_XOBTYPE_U_XOBDUZ_U_XOBDIVRQ("STATIONNUMBER")
176 ;
177 IF 'XOBOK DO ; A check failed. Clean up partition.
178 .;
179 .; -- reset DUZ
180 . KILL DUZ
181 . MERGE DUZ=XOBDUZSV
182 ;
183 ; -- send back error
184 QUIT $SELECT(XOBOK:0,1:XOBERR)
185 ;
186LOGINH() ; -- Check if system is currently allowing logins
187 ; Return:
188 ; 181004 : if logins are disabled
189 ; 0 : if logins are allowed
190 ;
191 NEW XOBINH,XQVOL,XUCI,XUENV,XUVOL,X,Y
192 ;
193 ; -- Setup XUENV, XUCI,XQVOL,XUVOL
194 DO XUVOL^XUS
195 ;
196 ; -- Check whether logins are disabled
197 SET XOBINH=$$INHIBIT^XUSRB()
198 QUIT $SELECT(XOBINH:181004,1:0)
199 ;
200NOACCESS(XOBID) ; -- Determine if user is allowed access via user active status & prohibited times checks
201 ;
202 NEW XOBERR,XOBNOACC,XOBRANGE
203 SET (XOBERR,XOBNOACC)=0
204 ;
205 ; -- user active status check & error processing
206 DO ACTUSR(.XOBID,.XOBERR)
207 ;
208 ; -- check if sign-on is attempted during prohibited times
209 IF 'XOBERR DO
210 . SET XOBRANGE=$$GET1^DIQ(200,XOBID,15)
211 . IF XOBRANGE DO
212 .. SET XOBNOACC=$$PROHIBIT^XUS1A($P($HOROLOG,",",2),XOBRANGE)
213 .. IF XOBNOACC SET XOBERR=182304_U_XOBID_U_"Prohibited time: "_$PIECE(XOBNOACC,U,2)
214 QUIT XOBERR
215 ;
216VCHG(XOBID) ; -- Check if verify code needs to be changed
217 ; Return:
218 ; 182303^XOBID : if verify code is undefined or expired
219 ; 0 : verify code is current
220 NEW DUZ,I,VCHG,XOPT
221 SET DUZ=+$GET(XOBID),VCHG=0
222 ;
223 ; -- set up XOPT
224 DO XOPT^XUS
225 ;
226 ; -- check if verify code is current
227 IF $$VCVALID^XUSRB() DO
228 . SET VCHG=182303_U_DUZ
229 QUIT VCHG
230 ;
231INIT ; -- VL-specific or general partition setup before reauthentication process starts
232 ;
233 LOCK
234 SET:$DATA(IO)[0 IO=$IO SET IO(0)=IO
235 KILL ^UTILITY($JOB),^TMP($JOB)
236 KILL ^XUTL("XQ",$JOB)
237 ; -- clean up partition's local symbol table
238 DO KILL^XOBSRA1
239 QUIT
240 ;
241FINAL ; -- Final setup needed after a re-authentication is performed successfully.
242 ; -- Save DUZ and IO variables in ^XUTL("XQ",$JOB)
243 DO SAVE^XUS1
244 ;
245 ; Change in XUSRB: calls POST2^XUSRB calls CLRFAC^XUS3 to clear Failed Signon Attempts
246 ; file of entry with given IP. Need IO("IP") obtained from ZIO^%ZIS4.
247 ;
248 KILL XQY,XQYQ
249 QUIT
250 ;
251GETERR(XOBACT,XOBID,XOBCONN) ;-- Get appropriate DIALOG file error
252 ;
253 NEW XOBERR
254 SET XOBERR=0
255 SET XOBACT=$GET(XOBACT),XOBID=$GET(XOBID),XOBCONN=$GET(XOBCONN)
256 ;
257 ;- error indicates that user can't sign on, is DISUSER'd, or is TERMINATED
258 IF $PIECE(XOBACT,U)=0 SET XOBERR=182304_U_XOBID_U_$SELECT($PIECE(XOBACT,U,2)'="":$PIECE(XOBACT,U,2),1:"Unable to Sign On")
259 ;
260 ;- error indicates no user record found
261 IF $PIECE(XOBACT,U)="" DO
262 . SET:XOBCONN="" XOBCONN="Unknown Reauthentication Type"
263 . SET XOBERR=182301_U_XOBCONN_U_" ["_XOBCONN_" reauthentication type, DUZ Value: '"_XOBID_"']"
264 QUIT XOBERR
265 ;
266SITECHK(XOBSTATN) ; check if valid division for this site
267 ; input: station#
268 ; output: IEN of station# in institution file (if valid for this site)
269 ; 0^error message (if not valid for this site)
270 N XOBSTIEN,XOBSTRIP
271 SET XOBSTRIP=$$STRPSUFF^XOBSCAV1(XOBSTATN)
272 QUIT:((+XOBSTRIP)'=XOBSYS("PRIMARY STATION#")) "0^STATION '"_XOBSTATN_"' is not supported by this M system."
273 S XOBSTIEN=$$IEN^XUAF4(XOBSTATN)
274 QUIT:'+XOBSTIEN "0^STATION '"_XOBSTATN_"' is not a known station number."
275 QUIT:'$$ACTIVE^XUAF4(XOBSTIEN) "0^STATION '"_XOBSTATN_"' is not active on this M system."
276 QUIT XOBSTIEN
Note: See TracBrowser for help on using the repository browser.