source: FOIAVistA/trunk/r/VISTALINK-XOBV/XOBVRPC.m@ 1535

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

initial load of FOIAVistA 6/30/08 version

File size: 7.8 KB
Line 
1XOBVRPC ;; mjk/alb - VistaLInk RPC Server Listener Code ; 07/27/2002 13:00
2 ;;1.5;VistALink;;Sep 09, 2005
3 ;;Foundations Toolbox Release v1.5 [Build: 1.5.0.026]
4 ;
5 QUIT
6 ;
7 ; ------------------------------------------------------------------------
8 ; RPC Server: Message Request Handler
9 ; ------------------------------------------------------------------------
10 ;
11EN(XOBDATA) ; -- handle parsed messages request
12 NEW DX,DY,RPC0,RPCNAME,RPCIEN,TAG,ROU,METHSIG,XOBERR,XOBR,XOBSEC,XOBWRAP,XOBPTYPE,XRTN,XOBRA,XOBVER
13 ;
14 IF $GET(XOBDATA("XOB RPC","RPC NAME"))="" DO GOTO ENQ
15 . DO ERROR(182001,"[No RPC]","")
16 ;
17 SET RPCNAME=XOBDATA("XOB RPC","RPC NAME")
18 ;
19 IF $DATA(^XWB(8994,"B",RPCNAME))=0 DO GOTO ENQ
20 . DO ERROR(182002,RPCNAME,RPCNAME)
21 ;
22 IF $DATA(^XWB(8994,"B",RPCNAME))=10 SET RPCIEN=+$ORDER(^XWB(8994,"B",RPCNAME,""))
23 ;
24 ; -- get zero node
25 SET RPC0=$GET(^XWB(8994,RPCIEN,0))
26 ;
27 ; -- make sure there is data on node
28 IF RPC0="" DO GOTO ENQ
29 . DO ERROR(182003,RPCNAME,RPCNAME)
30 ;
31 ; -- make sure x-ref is not corrupt and found the wrong entry
32 IF RPCNAME'=$PIECE(RPC0,U) DO GOTO ENQ
33 . NEW PARAMS SET PARAMS(1)=RPCNAME,PARAMS(2)=$PIECE(RPC0,U)
34 . DO ERROR(182008,RPCNAME,.PARAMS)
35 ;
36 ; -- check inactive flag
37 IF $PIECE(RPC0,U,6)=1!($PIECE(RPC0,U,6)=2) DO GOTO ENQ
38 . DO ERROR(182004,RPCNAME,RPCNAME)
39 ;
40 ; -- if not already performed, check version, environment and set re-auth check flag
41 SET XOBERR=$SELECT($DATA(XOBSYS("RPC REAUTH")):0,1:$$VER())
42 IF XOBERR DO GOTO ENQ
43 . DO ERROR(XOBERR,RPCNAME)
44 ;
45 ; -- reauthentication checks
46 SET XOBERR=0
47 IF +$GET(XOBSYS("RPC REAUTH")) DO GOTO:XOBERR ENQ
48 . ;
49 . ; -- reauthenticate user based on type (i.e. DUZ,AV,VPID,CCOW,APPPROXY)
50 . SET XOBERR=$$SETUPDUZ^XOBSRA()
51 . IF XOBERR DO ERROR(XOBERR,RPCNAME) QUIT
52 . ;
53 . ; -- if application proxy user, check if allowed to run RPC
54 . IF $$UP^XLFSTR(XOBDATA("XOB RPC","SECURITY","TYPE"))="APPPROXY",'$$RPC^XUSAP($GET(RPCIEN)) DO QUIT
55 .. SET XOBERR=182010
56 .. DO ERROR(XOBERR,RPCNAME,RPCNAME)
57 ;
58 ; -- set context
59 SET XOBSEC=$$CRCONTXT^XOBSCAV($GET(XOBDATA("XOB RPC","RPC CONTEXT")))
60 IF '+XOBSEC DO GOTO ENQ
61 . DO ERROR(182005,RPCNAME,XOBSEC)
62 ;
63 ; -- check if appropriate context created
64 SET XOBSEC=$$CHKCTXT^XOBSCAV(RPCNAME)
65 IF '+XOBSEC DO GOTO ENQ
66 . DO ERROR(182006,RPCNAME,XOBSEC)
67 ;
68 ; -- setup timeout info
69 SET XOBDATA("XOB RPC","TIMED OUT")=0
70 SET XOBDATA("XOB RPC","START")=$HOROLOG
71 ;
72 ; -- setup info needed for RPC execution
73 SET TAG=$PIECE(RPC0,U,2)
74 SET ROU=$PIECE(RPC0,U,3)
75 SET XOBPTYPE=$PIECE(RPC0,U,4)
76 SET XOBWRAP=$PIECE(RPC0,U,8)
77 SET XOBVER=$$GETVER^XOBVRPCX()
78 ;
79 ; -- build method signature
80 SET METHSIG=TAG_"^"_ROU_"(.XOBR"_$GET(XOBDATA("XOB RPC","PARAMS"))_")"
81 ;
82 ; -- start RTL
83 DO:$DATA(XRTL) T0^%ZOSV
84 ;
85 ; -- use null device in case of writing during RPC execution
86 USE XOBNULL
87 ;
88 ; -- start RUM for RPC Name
89 DO LOGRSRC^%ZOSV(RPCNAME,2,1)
90 ;
91 ; -- execute RPC
92 DO CALLRPC(.XOBPTYPE,.XOBWRAP,.XOBVER,METHSIG)
93 ;
94 ; -- re-start RUM for VistaLink Handler
95 DO LOGRSRC^%ZOSV("$VISTALINK HANDLER$",2,1)
96 ;
97 ; -- stop RTL
98 SET:$DATA(XRT0) XRTN=RPCNAME DO:$DATA(XRT0) T1^%ZOSV
99 ;
100 ; -- empty write buffer of null device
101 USE XOBNULL SET DX=0,DY=0 XECUTE ^%ZOSF("XY")
102 ;
103 ; -- reset to use tcp port device to send results
104 USE XOBPORT
105 ;
106 ; -- check for RPC processing timeout
107 IF $$TOCHK^XOBVLIB() DO GOTO ENQ
108 . NEW PARAMS SET PARAMS(1)=RPCNAME,PARAMS(2)=$$GETTO^XOBVLIB()
109 . DO ERROR(182007,RPCNAME,.PARAMS)
110 ;
111 ; -- send results
112 DO SEND(.XOBR)
113 ;
114ENQ ; -- end message handler
115 DO CLEAN
116 QUIT
117 ;
118CALLRPC(XWBPTYPE,XWBWRAP,XWBAPVER,METHSIG) ;-- execute RPC (use Broker RPC return type & wrap flag if there)
119 DO @METHSIG
120 QUIT
121 ;
122CLEAN ; -- clean up message handler environment
123 NEW POS
124 ; -- kill parameters
125 SET POS=0
126 FOR SET POS=$ORDER(XOBDATA("XOB RPC","PARAMS",POS)) QUIT:'POS KILL @XOBDATA("XOB RPC","PARAMS",POS)
127 QUIT
128 ;
129SEND(XOBR) ; -- stream rpc data to client
130 NEW XOBFMT,XOBFILL
131 ;
132 SET XOBFMT=$$GETFMT()
133 ; -- prepare socket for writing
134 DO PRE^XOBVSKT
135 ; -- initialize XML headers
136 DO WRITE^XOBVSKT($$VLHDR^XOBVLIB(1))
137 ; -- start response
138 DO WRITE^XOBVSKT("<Response type="""_XOBFMT_""" ><![CDATA[")
139 ; -- results
140 DO PROCESS
141 ; -- finalize
142 DO WRITE^XOBVSKT("]]></Response>"_$$ENVFTR^XOBVLIB())
143 ; -- send eot and flush buffer
144 DO POST^XOBVSKT
145 ;
146 QUIT
147 ;
148DOCTYPE ;
149 DO WRITE^XOBVSKT("<!DOCTYPE vistalink [<!ELEMENT vistalink (results) ><!ELEMENT results (#PCDATA)><!ATTLIST vistalink type CDATA ""Gov.VA.Med.RPC.Response"" ><!ATTLIST results type (array|string) >]>")
150 QUIT
151 ;
152GETFMT() ; -- determine response format type
153 IF XOBPTYPE=1!(XOBPTYPE=5)!(XOBPTYPE=6) QUIT "string"
154 IF XOBPTYPE=2 QUIT "array"
155 ;
156 QUIT $SELECT(XOBWRAP:"array",1:"string")
157 ;
158PROCESS ; -- send the real results
159 NEW I,T,D
160 ; -- single value
161 IF XOBPTYPE=1 SET XOBR=$GET(XOBR) DO WRITE^XOBVSKT(XOBR) QUIT
162 ; -- table delimited by CR+LF
163 IF XOBPTYPE=2 DO QUIT
164 . SET I="" FOR SET I=$ORDER(XOBR(I)) QUIT:I="" DO WRITE^XOBVSKT(XOBR(I)),WRITE^XOBVSKT($CHAR(10))
165 ; -- word processing
166 IF XOBPTYPE=3 DO QUIT
167 . SET I="" FOR SET I=$ORDER(XOBR(I)) QUIT:I="" DO WRITE^XOBVSKT(XOBR(I)) DO:XOBWRAP WRITE^XOBVSKT($CHAR(10))
168 ; -- global array
169 IF XOBPTYPE=4 DO QUIT
170 . IF $EXTRACT($GET(XOBR))'="^" QUIT
171 . SET I=$GET(XOBR) QUIT:I="" SET T=$EXTRACT(I,1,$LENGTH(I)-1)
172 . ;Only send root node if non-null.
173 . IF $DATA(@I)>10 SET D=@I IF $LENGTH(D) DO WRITE^XOBVSKT(D),WRITE^XOBVSKT($CHAR(10)):XOBWRAP&(D'=$CHAR(10))
174 . FOR SET I=$QUERY(@I) QUIT:I=""!(I'[T) SET D=@I DO WRITE^XOBVSKT(D),WRITE^XOBVSKT($CHAR(10)):XOBWRAP&(D'=$CHAR(10))
175 . IF $DATA(@XOBR) KILL @XOBR
176 ; -- global instance
177 IF XOBPTYPE=5 DO QUIT
178 . IF $EXTRACT($GET(XOBR))'="^" QUIT
179 . SET XOBR=$GET(@XOBR) DO WRITE^XOBVSKT(XOBR)
180 ; -- variable length records only good upto 255 char)
181 IF XOBPTYPE=6 DO
182 . SET I="" FOR SET I=$ORDER(XOBR(I)) QUIT:I="" DO WRITE^XOBVSKT($CHAR($LENGTH(XOBR(I)))),WRITE^XOBVSKT(XOBR(I))
183 QUIT
184 ;
185ERROR(CODE,RPCNAME,PARAMS) ; -- send rpc application error
186 ; -- if parameters are passed as in CODE (where CODE = code^param1^param2^...)
187 ; -- parse CODE and put parameters into PARAMS array.
188 IF CODE[U,$DATA(PARAMS)=0 DO
189 . KILL PARAMS
190 . FOR XOBI=2:1:$LENGTH(XOBERR,U) SET PARAMS(XOBI-1)=$PIECE(XOBERR,U,XOBI)
191 . SET CODE=+CODE
192 ;
193 SET XOBDAT("MESSAGE TYPE")=2
194 SET XOBDAT("ERRORS",1,"FAULT STRING")="Internal Application Error"
195 SET XOBDAT("ERRORS",1,"FAULT ACTOR")=RPCNAME
196 SET XOBDAT("ERRORS",1,"CODE")=CODE
197 SET XOBDAT("ERRORS",1,"ERROR TYPE")=RPCNAME
198 SET XOBDAT("ERRORS",1,"CDATA")=0
199 SET XOBDAT("ERRORS",1,"MESSAGE",1)=$$EZBLD^DIALOG(CODE,.PARAMS)
200 DO ERROR^XOBVLIB(.XOBDAT)
201 ;
202 ; -- save info in error system
203 ;DO ^%ZTER
204 QUIT
205 ;
206VER() ; -- check version and if re-authentication check is needed
207 ; -- IMPORTANT: This tag needs updating for version numbers for each target release.
208 ; -- This call needs only be called once per connection.
209 ;
210 NEW XOBERR,CV,SV,ENV
211 ;
212 KILL XOBSYS("RPC REAUTH")
213 ;
214 SET XOBERR=0
215 ; -- default re-auh flag to true
216 SET XOBRA=1
217 ; -- client version
218 SET CV=XOBDATA("XOB RPC","RPC HANDLER VERSION")
219 ; -- current server version
220 SET SV="1.5"
221 ; -- client environment
222 SET ENV=XOBSYS("ENV")
223 ;
224 ; -- if client version is not supported then return error
225 IF ("^1.0^1.5^")'[(U_CV_U) DO GOTO VERQ
226 . SET XOBERR=182009_U_CV_U_SV_U_"Client version not supported"
227 ;
228 ; -- if client environment is not supported then return error
229 IF ("^j2se^j2ee^.net^")'[(U_ENV_U) DO GOTO VERQ
230 . SET XOBERR=182009_U_CV_U_SV_U_"Client environment ("_$$UP^XLFSTR(ENV)_") not supported"
231 ;
232 ; -- if client/server environment then ok
233 IF ("^j2se^.net^")[(U_ENV_U) SET XOBRA=0 GOTO VERQ
234 ;
235 ; -- if client version is "1.0" and client is j2ee then return error
236 IF CV="1.0",ENV="j2ee" DO GOTO VERQ
237 . SET XOBERR=182009_U_CV_U_SV_U_"Client RPC version does not support "_$$UP^XLFSTR(ENV)
238 ;
239 ; -- if client version supports j2ee and client is j2ee then ok (default)
240 ;IF ENV="j2ee" GOTO VERQ
241 ;
242VERQ ;
243 IF 'XOBERR SET XOBSYS("RPC REAUTH")=XOBRA
244 QUIT XOBERR
245 ;
Note: See TracBrowser for help on using the repository browser.