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.5;VistALink;;Sep 09, 2005
  1.  ;;Foundations Toolbox Release v1.5 [Build: 1.5.0.026]
  1.  ;
  1.  QUIT
  1.  ;
  1.  ; ------------------------------------------------------------------------
  1.  ;                   RPC Server: Message Request Handler         
  1.  ; ------------------------------------------------------------------------
  1.  ; 
  1. EN(XOBDATA) ; -- handle parsed messages request
  1.  NEW DX,DY,RPC0,RPCNAME,RPCIEN,TAG,ROU,METHSIG,XOBERR,XOBR,XOBSEC,XOBWRAP,XOBPTYPE,XRTN,XOBRA,XOBVER
  1.  ;
  1.  IF $GET(XOBDATA("XOB RPC","RPC NAME"))="" DO  GOTO ENQ
  1.  . DO ERROR(182001,"[No RPC]","")
  1.  ;
  1.  SET RPCNAME=XOBDATA("XOB RPC","RPC NAME")
  1.  ;
  1.  IF $DATA(^XWB(8994,"B",RPCNAME))=0 DO  GOTO ENQ
  1.  . DO ERROR(182002,RPCNAME,RPCNAME)
  1.  ;
  1.  IF $DATA(^XWB(8994,"B",RPCNAME))=10 SET RPCIEN=+$ORDER(^XWB(8994,"B",RPCNAME,""))
  1.  ;
  1.  ; -- get zero node
  1.  SET RPC0=$GET(^XWB(8994,RPCIEN,0))
  1.  ;
  1.  ; -- make sure there is data on node
  1.  IF RPC0="" DO  GOTO ENQ
  1.  . DO ERROR(182003,RPCNAME,RPCNAME)
  1.  ;
  1.  ; -- make sure x-ref is not corrupt and found the wrong entry
  1.  IF RPCNAME'=$PIECE(RPC0,U) DO  GOTO ENQ
  1.  . NEW PARAMS SET PARAMS(1)=RPCNAME,PARAMS(2)=$PIECE(RPC0,U)
  1.  . DO ERROR(182008,RPCNAME,.PARAMS)
  1.  ;
  1.  ; -- check inactive flag
  1.  IF $PIECE(RPC0,U,6)=1!($PIECE(RPC0,U,6)=2) DO  GOTO ENQ
  1.  . DO ERROR(182004,RPCNAME,RPCNAME)
  1.  ;
  1.  ; -- if not already performed, check version, environment and set re-auth check flag
  1.  SET XOBERR=$SELECT($DATA(XOBSYS("RPC REAUTH")):0,1:$$VER())
  1.  IF XOBERR DO  GOTO ENQ
  1.  . DO ERROR(XOBERR,RPCNAME)
  1.  ;
  1.  ; -- reauthentication checks
  1.  SET XOBERR=0
  1.  IF +$GET(XOBSYS("RPC REAUTH")) DO  GOTO:XOBERR ENQ
  1.  . ;
  1.  . ; -- reauthenticate user based on type (i.e. DUZ,AV,VPID,CCOW,APPPROXY)
  1.  . SET XOBERR=$$SETUPDUZ^XOBSRA()
  1.  . IF XOBERR DO ERROR(XOBERR,RPCNAME) QUIT
  1.  . ;
  1.  . ; -- if application proxy user, check if allowed to run RPC
  1.  . IF $$UP^XLFSTR(XOBDATA("XOB RPC","SECURITY","TYPE"))="APPPROXY",'$$RPC^XUSAP($GET(RPCIEN)) DO  QUIT
  1.  .. SET XOBERR=182010
  1.  .. DO ERROR(XOBERR,RPCNAME,RPCNAME)
  1.  ;
  1.  ; -- set context
  1.  SET XOBSEC=$$CRCONTXT^XOBSCAV($GET(XOBDATA("XOB RPC","RPC CONTEXT")))
  1.  IF '+XOBSEC DO  GOTO ENQ
  1.  . DO ERROR(182005,RPCNAME,XOBSEC)
  1.  ;
  1.  ; -- check if appropriate context created
  1.  SET XOBSEC=$$CHKCTXT^XOBSCAV(RPCNAME)
  1.  IF '+XOBSEC DO  GOTO ENQ
  1.  . DO ERROR(182006,RPCNAME,XOBSEC)
  1.  ;
  1.  ; -- setup timeout info
  1.  SET XOBDATA("XOB RPC","TIMED OUT")=0
  1.  SET XOBDATA("XOB RPC","START")=$HOROLOG
  1.  ;
  1.  ; -- setup info needed for RPC execution
  1.  SET TAG=$PIECE(RPC0,U,2)
  1.  SET ROU=$PIECE(RPC0,U,3)
  1.  SET XOBPTYPE=$PIECE(RPC0,U,4)
  1.  SET XOBWRAP=$PIECE(RPC0,U,8)
  1.  SET XOBVER=$$GETVER^XOBVRPCX()
  1.  ;
  1.  ; -- build method signature
  1.  SET METHSIG=TAG_"^"_ROU_"(.XOBR"_$GET(XOBDATA("XOB RPC","PARAMS"))_")"
  1.  ;
  1.  ; -- start RTL
  1.  DO:$DATA(XRTL) T0^%ZOSV
  1.  ;
  1.  ; -- use null device in case of writing during RPC execution
  1.  USE XOBNULL
  1.  ;
  1.  ; -- start RUM for RPC Name
  1.  DO LOGRSRC^%ZOSV(RPCNAME,2,1)
  1.  ;
  1.  ; -- execute RPC
  1.  DO CALLRPC(.XOBPTYPE,.XOBWRAP,.XOBVER,METHSIG)
  1.  ;
  1.  ; -- re-start RUM for VistaLink Handler
  1.  DO LOGRSRC^%ZOSV("$VISTALINK HANDLER$",2,1)
  1.  ;
  1.  ; -- stop RTL
  1.  SET:$DATA(XRT0) XRTN=RPCNAME DO:$DATA(XRT0) T1^%ZOSV
  1.  ;
  1.  ; -- empty write buffer of null device
  1.  USE XOBNULL SET DX=0,DY=0 XECUTE ^%ZOSF("XY")
  1.  ;
  1.  ; -- reset to use tcp port device to send results
  1.  USE XOBPORT
  1.  ;
  1.  ; -- check for RPC processing timeout
  1.  IF $$TOCHK^XOBVLIB() DO  GOTO ENQ
  1.  . NEW PARAMS SET PARAMS(1)=RPCNAME,PARAMS(2)=$$GETTO^XOBVLIB()
  1.  . DO ERROR(182007,RPCNAME,.PARAMS)
  1.  ;
  1.  ; -- send results
  1.  DO SEND(.XOBR)
  1.  ;
  1. ENQ ; -- end message handler
  1.  DO CLEAN
  1.  QUIT
  1.  ;
  1. CALLRPC(XWBPTYPE,XWBWRAP,XWBAPVER,METHSIG) ;-- execute RPC (use Broker RPC return type & wrap flag if there)
  1.  DO @METHSIG
  1.  QUIT
  1.  ;
  1. CLEAN ; -- clean up message handler environment
  1.  NEW POS
  1.  ; -- kill parameters
  1.  SET POS=0
  1.  FOR  SET POS=$ORDER(XOBDATA("XOB RPC","PARAMS",POS)) QUIT:'POS  KILL @XOBDATA("XOB RPC","PARAMS",POS)
  1.  QUIT
  1.  ;
  1. SEND(XOBR) ; -- stream rpc data to client
  1.  NEW XOBFMT,XOBFILL
  1.  ;
  1.  SET XOBFMT=$$GETFMT()
  1.  ; -- prepare socket for writing
  1.  DO PRE^XOBVSKT
  1.  ; -- initialize XML headers
  1.  DO WRITE^XOBVSKT($$VLHDR^XOBVLIB(1))
  1.  ; -- start response
  1.  DO WRITE^XOBVSKT("<Response type="""_XOBFMT_""" ><![CDATA[")
  1.  ; -- results
  1.  DO PROCESS
  1.  ; -- finalize
  1.  DO WRITE^XOBVSKT("]]></Response>"_$$ENVFTR^XOBVLIB())
  1.  ; -- send eot and flush buffer
  1.  DO POST^XOBVSKT
  1.  ;
  1.  QUIT
  1.  ;
  1. DOCTYPE ;
  1.  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) >]>")
  1.  QUIT
  1.  ;
  1. GETFMT() ; -- determine response format type
  1.  IF XOBPTYPE=1!(XOBPTYPE=5)!(XOBPTYPE=6) QUIT "string"
  1.  IF XOBPTYPE=2 QUIT "array"
  1.  ;
  1.  QUIT $SELECT(XOBWRAP:"array",1:"string")
  1.  ;
  1. PROCESS ; -- send the real results
  1.  NEW I,T,D
  1.  ; -- single value
  1.  IF XOBPTYPE=1 SET XOBR=$GET(XOBR) DO WRITE^XOBVSKT(XOBR) QUIT
  1.  ; -- table delimited by CR+LF
  1.  IF XOBPTYPE=2 DO  QUIT
  1.  . SET I="" FOR  SET I=$ORDER(XOBR(I)) QUIT:I=""  DO WRITE^XOBVSKT(XOBR(I)),WRITE^XOBVSKT($CHAR(10))
  1.  ; -- word processing
  1.  IF XOBPTYPE=3 DO  QUIT
  1.  . SET I="" FOR  SET I=$ORDER(XOBR(I)) QUIT:I=""  DO WRITE^XOBVSKT(XOBR(I)) DO:XOBWRAP WRITE^XOBVSKT($CHAR(10))
  1.  ; -- global array
  1.  IF XOBPTYPE=4 DO  QUIT
  1.  . IF $EXTRACT($GET(XOBR))'="^" QUIT
  1.  . SET I=$GET(XOBR) QUIT:I=""  SET T=$EXTRACT(I,1,$LENGTH(I)-1)
  1.  . ;Only send root node if non-null.
  1.  . IF $DATA(@I)>10 SET D=@I IF $LENGTH(D) DO WRITE^XOBVSKT(D),WRITE^XOBVSKT($CHAR(10)):XOBWRAP&(D'=$CHAR(10))
  1.  . FOR  SET I=$QUERY(@I) QUIT:I=""!(I'[T)  SET D=@I DO WRITE^XOBVSKT(D),WRITE^XOBVSKT($CHAR(10)):XOBWRAP&(D'=$CHAR(10))
  1.  . IF $DATA(@XOBR) KILL @XOBR
  1.  ; -- global instance
  1.  IF XOBPTYPE=5 DO  QUIT
  1.  . IF $EXTRACT($GET(XOBR))'="^" QUIT
  1.  . SET XOBR=$GET(@XOBR) DO WRITE^XOBVSKT(XOBR)
  1.  ; -- variable length records only good upto 255 char)
  1.  IF XOBPTYPE=6 DO
  1.  . SET I="" FOR  SET I=$ORDER(XOBR(I)) QUIT:I=""  DO WRITE^XOBVSKT($CHAR($LENGTH(XOBR(I)))),WRITE^XOBVSKT(XOBR(I))
  1.  QUIT
  1.  ;
  1. ERROR(CODE,RPCNAME,PARAMS) ; -- send rpc application error
  1.  ; -- if parameters are passed as in CODE (where CODE = code^param1^param2^...)
  1.  ; -- parse CODE and put parameters into PARAMS array.
  1.  IF CODE[U,$DATA(PARAMS)=0 DO
  1.  . KILL PARAMS
  1.  . FOR XOBI=2:1:$LENGTH(XOBERR,U) SET PARAMS(XOBI-1)=$PIECE(XOBERR,U,XOBI)
  1.  . SET CODE=+CODE
  1.  ;
  1.  SET XOBDAT("MESSAGE TYPE")=2
  1.  SET XOBDAT("ERRORS",1,"FAULT STRING")="Internal Application Error"
  1.  SET XOBDAT("ERRORS",1,"FAULT ACTOR")=RPCNAME
  1.  SET XOBDAT("ERRORS",1,"CODE")=CODE
  1.  SET XOBDAT("ERRORS",1,"ERROR TYPE")=RPCNAME
  1.  SET XOBDAT("ERRORS",1,"CDATA")=0
  1.  SET XOBDAT("ERRORS",1,"MESSAGE",1)=$$EZBLD^DIALOG(CODE,.PARAMS)
  1.  DO ERROR^XOBVLIB(.XOBDAT)
  1.  ;
  1.  ; -- save info in error system
  1.  ;DO ^%ZTER
  1.  QUIT
  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.  NEW XOBERR,CV,SV,ENV
  1.  ;
  1.  KILL XOBSYS("RPC REAUTH")
  1.  ;
  1.  SET XOBERR=0
  1.  ; -- default re-auh flag to true
  1.  SET XOBRA=1
  1.  ; -- client version
  1.  SET CV=XOBDATA("XOB RPC","RPC HANDLER VERSION")
  1.  ; -- current server version
  1.  SET SV="1.5"
  1.  ; -- client environment
  1.  SET ENV=XOBSYS("ENV")
  1.  ;
  1.  ; -- if client version is not supported then return error
  1.  IF ("^1.0^1.5^")'[(U_CV_U) DO  GOTO VERQ
  1.  . SET XOBERR=182009_U_CV_U_SV_U_"Client version not supported"
  1.  ;
  1.  ; -- if client environment is not supported then return error
  1.  IF ("^j2se^j2ee^.net^")'[(U_ENV_U) DO  GOTO VERQ
  1.  . SET XOBERR=182009_U_CV_U_SV_U_"Client environment ("_$$UP^XLFSTR(ENV)_") not supported"
  1.  ;
  1.  ; -- if client/server environment then ok
  1.  IF ("^j2se^.net^")[(U_ENV_U) SET XOBRA=0 GOTO VERQ
  1.  ;
  1.  ; -- if client version is "1.0" and client is j2ee then return error
  1.  IF CV="1.0",ENV="j2ee" DO  GOTO VERQ
  1.  . SET 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.  IF 'XOBERR SET XOBSYS("RPC REAUTH")=XOBRA
  1.  QUIT XOBERR
  1.  ;