Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XOBVRPC

XOBVRPC.m

Go to the documentation of this file.
  1. XOBVRPC ;; mjk/alb - VistaLink RPC Server Listener Code ; 07/27/2002 13:00
  1. ;;1.6;VistALink Security;**4**;May 08, 2009;Build 7
  1. ; ;Per VA Directive 6402, this routine should not be modified.
  1. Q
  1. ;
  1. ; ------------------------------------------------------------------------
  1. ; RPC Server: Message Request Handler
  1. ; ------------------------------------------------------------------------
  1. ;
  1. EN(XOBDATA) ; -- handle parsed messages request
  1. N DX,DY,RPC0,RPCNAME,RPCIEN,TAG,ROU,METHSIG,XOBERR,XOBR,XOBSEC,XOBWRAP,XOBPTYPE,XRTN,XOBRA,XOBVER
  1. ;
  1. I $G(XOBDATA("XOB RPC","RPC NAME"))="" D G ENQ
  1. . D ERROR(182001,"[No RPC]","")
  1. ;
  1. S RPCNAME=XOBDATA("XOB RPC","RPC NAME")
  1. ;
  1. I $D(^XWB(8994,"B",RPCNAME))=0 D G ENQ
  1. . D ERROR(182002,RPCNAME,RPCNAME)
  1. ;
  1. I $D(^XWB(8994,"B",RPCNAME))=10 S RPCIEN=+$O(^XWB(8994,"B",RPCNAME,""))
  1. ;
  1. ; -- get zero node
  1. S RPC0=$G(^XWB(8994,RPCIEN,0))
  1. ;
  1. ; -- make sure there is data on node
  1. I RPC0="" D G ENQ
  1. . D ERROR(182003,RPCNAME,RPCNAME)
  1. ;
  1. ; -- make sure x-ref is not corrupt and found the wrong entry
  1. I RPCNAME'=$P(RPC0,U) D G ENQ
  1. . N PARAMS S PARAMS(1)=RPCNAME,PARAMS(2)=$P(RPC0,U)
  1. . D ERROR(182008,RPCNAME,.PARAMS)
  1. ;
  1. ; -- check inactive flag
  1. I $P(RPC0,U,6)=1!($P(RPC0,U,6)=2) D G ENQ
  1. . D ERROR(182004,RPCNAME,RPCNAME)
  1. ;
  1. ; -- if not already performed, check version, environment and set re-auth check flag
  1. S XOBERR=$S($D(XOBSYS("RPC REAUTH")):0,1:$$VER())
  1. I XOBERR D G ENQ
  1. . D ERROR(XOBERR,RPCNAME)
  1. ;
  1. ; -- reauthentication checks
  1. S XOBERR=0
  1. I +$G(XOBSYS("RPC REAUTH")) D G:XOBERR ENQ
  1. . ;
  1. . ; -- reauthenticate user based on type (i.e. DUZ,AV,VPID,CCOW,APPPROXY)
  1. . S XOBERR=$$SETUPDUZ^XOBSRA()
  1. . I XOBERR D ERROR(XOBERR,RPCNAME) Q
  1. . ;
  1. . ; -- if application proxy user, check if allowed to run RPC
  1. . I $$UP^XLFSTR(XOBDATA("XOB RPC","SECURITY","TYPE"))="APPPROXY",'$$RPC^XUSAP($G(RPCIEN)) D Q
  1. .. S XOBERR=182010
  1. .. D ERROR(XOBERR,RPCNAME,RPCNAME)
  1. ;
  1. ; -- set context
  1. S XOBSEC=$$CRCONTXT^XOBSCAV($G(XOBDATA("XOB RPC","RPC CONTEXT")))
  1. I '+XOBSEC D G ENQ
  1. . D ERROR(182005,RPCNAME,XOBSEC)
  1. ;
  1. ; -- check if appropriate context created
  1. S XOBSEC=$$CHKCTXT^XOBSCAV(RPCNAME)
  1. I '+XOBSEC D G ENQ
  1. . D ERROR(182006,RPCNAME,XOBSEC)
  1. ;
  1. ; -- setup timeout info
  1. S XOBDATA("XOB RPC","TIMED OUT")=0
  1. S XOBDATA("XOB RPC","START")=$H
  1. ;
  1. ; -- setup info needed for RPC execution
  1. S TAG=$P(RPC0,U,2)
  1. S ROU=$P(RPC0,U,3)
  1. S XOBPTYPE=$P(RPC0,U,4)
  1. S XOBWRAP=$P(RPC0,U,8)
  1. S XOBVER=$$GETVER^XOBVRPCX()
  1. ;
  1. ; -- build method signature
  1. S METHSIG=TAG_"^"_ROU_"(.XOBR"_$G(XOBDATA("XOB RPC","PARAMS"))_")"
  1. ;
  1. ; -- start RTL
  1. D:$D(XRTL) T0^%ZOSV
  1. ;
  1. ; -- use null device in case of writing during RPC execution
  1. U XOBNULL
  1. ;
  1. ; -- start RUM for RPC Name
  1. D LOGRSRC^%ZOSV(RPCNAME,2,1)
  1. ;
  1. ; -- execute RPC
  1. D CALLRPC(.XOBPTYPE,.XOBWRAP,.XOBVER,METHSIG)
  1. ;
  1. ; -- re-start RUM for VistaLink Handler
  1. D LOGRSRC^%ZOSV("$VISTALINK HANDLER$",2,1)
  1. ;
  1. ; -- stop RTL
  1. S:$D(XRT0) XRTN=RPCNAME D:$D(XRT0) T1^%ZOSV
  1. ;
  1. ; -- empty write buffer of null device
  1. U XOBNULL S DX=0,DY=0 X ^%ZOSF("XY")
  1. ;
  1. ; -- reset to use tcp port device to send results
  1. U XOBPORT
  1. ;
  1. ; -- check for RPC processing timeout
  1. I $$TOCHK^XOBVLIB() D G ENQ
  1. . N PARAMS S PARAMS(1)=RPCNAME,PARAMS(2)=$$GETTO^XOBVLIB()
  1. . D ERROR(182007,RPCNAME,.PARAMS)
  1. ;
  1. ; -- send results
  1. D SEND(.XOBR)
  1. ;
  1. ENQ ; -- end message handler
  1. D CLEAN
  1. Q
  1. ;
  1. CALLRPC(XWBPTYPE,XWBWRAP,XWBAPVER,METHSIG) ;-- execute RPC (use Broker RPC return type & wrap flag if there)
  1. D @METHSIG
  1. Q
  1. ;
  1. CLEAN ; -- clean up message handler environment
  1. N POS
  1. ; -- kill parameters
  1. S POS=0
  1. F S POS=$O(XOBDATA("XOB RPC","PARAMS",POS)) Q:'POS K @XOBDATA("XOB RPC","PARAMS",POS)
  1. Q
  1. ;
  1. SEND(XOBR) ; -- stream rpc data to client
  1. N XOBFMT,XOBFILL
  1. ;
  1. S XOBFMT=$$GETFMT()
  1. ; -- prepare socket for writing
  1. D PRE^XOBVSKT
  1. ; -- initialize XML headers
  1. D WRITE^XOBVSKT($$VLHDR^XOBVLIB(1))
  1. ; -- start response
  1. D WRITE^XOBVSKT("<Response type="""_XOBFMT_""" ><![CDATA[")
  1. ; -- results
  1. D PROCESS
  1. ; -- finalize
  1. D WRITE^XOBVSKT("]]></Response>"_$$ENVFTR^XOBVLIB())
  1. ; -- send eot and flush buffer
  1. D POST^XOBVSKT
  1. ;
  1. Q
  1. ;
  1. DOCTYPE ;
  1. D WRITE^XOBVSKT("<!DOCTYPE vistalink [<!ELEMENT vistalink (results) ><!ELEMENT results (#PCDATA)><!ATTLIST vistalink type CDATA ""Gov.VA.Med.RPC.Response"" ><!ATTLIST results type (array|string) >]>")
  1. Q
  1. ;
  1. GETFMT() ; -- determine response format type
  1. I XOBPTYPE=1!(XOBPTYPE=5)!(XOBPTYPE=6) Q "string"
  1. I XOBPTYPE=2 Q "array"
  1. ;
  1. Q $S(XOBWRAP:"array",1:"string")
  1. ;
  1. PROCESS ; -- send the real results
  1. N I,T,D
  1. ; -- single value
  1. I XOBPTYPE=1 S XOBR=$G(XOBR) D WRITE^XOBVSKT(XOBR) Q
  1. ; -- table delimited by CR+LF
  1. I XOBPTYPE=2 D Q
  1. . S I="" F S I=$O(XOBR(I)) Q:I="" D WRITE^XOBVSKT(XOBR(I)),WRITE^XOBVSKT($C(10))
  1. ; -- word processing
  1. I XOBPTYPE=3 D Q
  1. . S I="" F S I=$O(XOBR(I)) Q:I="" D WRITE^XOBVSKT(XOBR(I)) D:XOBWRAP WRITE^XOBVSKT($C(10))
  1. ; -- global array
  1. I XOBPTYPE=4 D Q
  1. . I $E($G(XOBR))'="^" Q
  1. . S I=$G(XOBR) Q:I="" S T=$E(I,1,$L(I)-1)
  1. . ;Only send root node if non-null.
  1. . I $D(@I)>10 S D=@I I $L(D) D WRITE^XOBVSKT(D),WRITE^XOBVSKT($C(10)):XOBWRAP&(D'=$C(10))
  1. . F S I=$Q(@I) Q:I=""!(I'[T) S D=@I D WRITE^XOBVSKT(D),WRITE^XOBVSKT($C(10)):XOBWRAP&(D'=$C(10))
  1. . I $D(@XOBR) K @XOBR
  1. ; -- global instance
  1. I XOBPTYPE=5 D Q
  1. . I $E($G(XOBR))'="^" Q
  1. . S XOBR=$G(@XOBR) D WRITE^XOBVSKT(XOBR)
  1. ; -- variable length records only good up to 255 char)
  1. I XOBPTYPE=6 D
  1. . S I="" F S I=$O(XOBR(I)) Q:I="" D WRITE^XOBVSKT($C($L(XOBR(I)))),WRITE^XOBVSKT(XOBR(I))
  1. Q
  1. ;
  1. ERROR(CODE,RPCNAME,PARAMS) ; -- send rpc application error
  1. N XOBI,XOBDAT,$ET,$ES
  1. ; -- if parameters are passed as in CODE (where CODE = code^param1^param2^...)
  1. ; -- parse CODE and put parameters into PARAMS array.
  1. I CODE[U,$D(PARAMS)=0 D
  1. . K PARAMS
  1. . F XOBI=2:1:$L(XOBERR,U) S PARAMS(XOBI-1)=$P(XOBERR,U,XOBI)
  1. . S CODE=+CODE
  1. ;
  1. S XOBDAT("MESSAGE TYPE")=2
  1. S XOBDAT("ERRORS",1,"FAULT STRING")="Internal Application Error"
  1. S XOBDAT("ERRORS",1,"FAULT ACTOR")=RPCNAME
  1. S XOBDAT("ERRORS",1,"CODE")=CODE
  1. S XOBDAT("ERRORS",1,"ERROR TYPE")=RPCNAME
  1. S XOBDAT("ERRORS",1,"CDATA")=0
  1. S XOBDAT("ERRORS",1,"MESSAGE",1)=$$EZBLD^DIALOG(CODE,.PARAMS)
  1. D ERROR^XOBVLIB(.XOBDAT)
  1. ;
  1. ; -- save info in error system
  1. D APPERROR^%ZTER("VistALink Error "_CODE) ;*4
  1. Q
  1. ;
  1. VER() ; -- check version and if re-authentication check is needed
  1. ; -- IMPORTANT: This tag needs updating for version numbers for each target release.
  1. ; -- This call needs only be called once per connection.
  1. ;
  1. N XOBERR,CV,SV,ENV
  1. ;
  1. K XOBSYS("RPC REAUTH")
  1. ;
  1. S XOBERR=0
  1. ; -- default re-auh flag to true
  1. S XOBRA=1
  1. ; -- client version
  1. S CV=XOBDATA("XOB RPC","RPC HANDLER VERSION")
  1. ; -- current server version
  1. S SV="1.6"
  1. ; -- client environment
  1. S ENV=XOBSYS("ENV")
  1. ;
  1. ; -- if client version is not supported then return error
  1. I ("^1.0^1.5^1.6^")'[(U_CV_U) D G VERQ
  1. . S XOBERR=182009_U_CV_U_SV_U_"Client version not supported"
  1. ;
  1. ; -- if client environment is not supported then return error
  1. I ("^j2se^j2ee^.net^")'[(U_ENV_U) D G VERQ
  1. . S XOBERR=182009_U_CV_U_SV_U_"Client environment ("_$$UP^XLFSTR(ENV)_") not supported"
  1. ;
  1. ; -- if client/server environment then ok
  1. I ("^j2se^.net^")[(U_ENV_U) S XOBRA=0 G VERQ
  1. ;
  1. ; -- if client version is "1.0" and client is j2ee then return error
  1. I CV="1.0",ENV="j2ee" D G VERQ
  1. . S XOBERR=182009_U_CV_U_SV_U_"Client RPC version does not support "_$$UP^XLFSTR(ENV)
  1. ;
  1. ; -- if client version supports j2ee and client is j2ee then ok (default)
  1. ;IF ENV="j2ee" GOTO VERQ
  1. ;
  1. VERQ ;
  1. I 'XOBERR S XOBSYS("RPC REAUTH")=XOBRA
  1. Q XOBERR
  1. ;