XWBTCPL ;SLC/KCM - Listener for TCP connects [ 02/13/95 9:01 PM ] ;10/16/96 11:33
;;1.1T3;RPC BROKER;;Nov 25, 1996
;ISC-SF/EG - DHCP Broker
;
; This routine is the background process that listens for client
; requests to connect to M. When a request is received, This
; procedure will job a s small routine to listen for new requests
; on the known service port.
;
; This job may be started in the background with: D STRT^XWBTCP(PORT)
;
; When running, this job may be stopped with: D STOP^XWBTCP(PORT)
;
; Where port is the known service port to listen for connections
;
EN(XWBTSKT) ; -- accept clients and start the individual message handler
N IP,REF,RETRY,XWBVER
S U="^"
S RETRY="START"
X ^%ZOSF("UCI") S REF=Y
S IP="0.0.0.0" ;get server IP
IF $G(XWBTSKT)="" S XWBTSKT=9000 ; default service port
S XWBTDEV=XWBTSKT
;
D SETNM^%ZOSV($E("RPCB_Port:"_XWBTSKT,1,15)) ;change process name
N LEN,MSG,XWBOS,DONE,DSMTCP,X
; -- check the TCP stop parameter
;IF $G(^XWB(IP,REF,XWBTSKT,"STOP")) K ^XWB(IP,REF,XWBTSKT) Q ; -- change to param file later ***
Q:'$$SEMAPHOR(XWBTSKT,"LOCK") ; -- quit if job is already running
;
D UPDTREC(XWBTSKT,3) ;updt RPC BROKER SITE PARAMETER record as RUNNING
;
RESTART ;
S DONE=0
S XWBOS=$S(^%ZOSF("OS")["DSM":"DSM",^("OS")["MSM":"MSM",^("OS")["OpenM":"OpenM",1:"")
IF $$NEWERR^%ZTER N $ESTACK S $ETRAP="S %ZTER11S=$STACK D ETRAP^XWBTCPL"
E S X="ETRAP^XWBTCPL",@^%ZOSF("TRAP")
;
; -- check the TCP stop parameter
;IF $G(^XWB(IP,REF,XWBTSKT,"STOP")) K ^XWB(IP,REF,XWBTSKT) Q ; -- change to param file later ***
;
I XWBOS="DSM" O XWBTSKT:TCPCHAN:5 ;Open listener
; -- loop until TCP stop parameter is set
;F D Q:$G(^XWB(IP,REF,XWBTSKT,"STOP"))
F D Q:DONE
. L +^XWB(IP,REF,XWBTSKT,"PROBLEM MARKER")
. K ^XWB(IP,REF,XWBTSKT,"PROBLEM MARKER") ;clear problem marker
. L -^XWB(IP,REF,XWBTSKT,"PROBLEM MARKER")
. ;
. ; -- listen for connect & get the initial message from the client
. I XWBOS="DSM" U XWBTSKT
. I XWBOS="MSM" S XWBTDEV=56 O 56 U 56::"TCP" W /SOCKET("",XWBTSKT)
. I XWBOS="OpenM" S XWBTDEV="|TCP|"_XWBTSKT O XWBTDEV:(:XWBTSKT:"AT") U XWBTDEV R *X
. S XWBVER=0
. R LEN#11 IF $E(LEN,1,5)'="{XWB}" Q
. IF $E(LEN,11,11)="|" D
. . R X#1
. . R XWBVER#$A(X)
. . R LEN#5
. . R MSG#LEN
. ELSE S X=$E(LEN,11,11),LEN=$E(LEN,6,10)-1 R MSG#LEN S MSG=X_MSG
. ; -- msg should be: action^client IP^client port^token
. ;
. ; -- if the action is TCPconnect (usual case)
. I $P(MSG,"^")="TCPconnect" D
. . ;-- decrypt token
. . N X,%T S X="",%T=0
. . IF XWBOS="DSM" J EN^XWBTCPC($P(MSG,"^",2),$P(MSG,"^",3),$P(X,"^"),XWBVER):OPTION="/SYMBOL=100000":5 S %T=$T
. . IF XWBOS="MSM" J EN^XWBTCPC($P(MSG,"^",2),$P(MSG,"^",3),$P(X,"^"),XWBVER):100000:5 S %T=$T
. . I XWBOS="OpenM" J EN^XWBTCPC($P(MSG,"^",2),$P(MSG,"^",3),$P(X,"^"),XWBVER)::5 S %T=$T
. . I %T D SNDERR W "accept",$C(4),!
. . E D SNDERR W "reject",$C(4),! S ^TMP("TCP",$P($H,",",2))="REJECT"
. ;
. ; -- if the action is TCPdebug (when msg handler run interactively)
. I $P(MSG,"^")="TCPdebug" D SNDERR W "accept",$C(4),!
. ;
. ; -- if the action is TCPshutdown, this listener will quit if the
. ; stop flag has been set. This request comes from an M process.
. I $P(MSG,"^")="TCPshutdown" S DONE=1 W "ack",!
. ;Now release the connection.
. I XWBOS="DSM" U XWBTSKT:DISCONNECT ; release this socket
. I XWBOS="MSM" C 56
. I XWBOS="OpenM" C XWBTDEV
. Q
; -- loop end
;
IF XWBOS="DSM" C XWBTSKT
S %=$$SEMAPHOR(XWBTSKT,"UNLOCK") ; destroy 'running flag'
;K ^XWB(IP,REF,XWBTSKT,"STOP")
D UPDTREC(XWBTSKT,6) ;updt RPC BROKER SITE PARAMETER record as STOPPED
Q
;
ETRAP ; -- on trapped error, send error info to client
N XWBERR
S XWBERR=$C(24)_"M ERROR="_$ZERROR_$C(13,10)_"LAST REF="_$ZR_$C(4)
D ^%ZTER ;Record it
S RETRY=RETRY+1 H 3
IF RETRY=5 H ;give up trying, server should not restart
IF $$NEWERR^%ZTER S $ETRAP="Q:($ESTACK&'$QUIT) Q:$ESTACK 0 S $ECODE="""" G RESTART^XWBTCPL"
IF XWBOS="DSM" D
. I $D(XWBTLEN),XWBTLEN,$ZE'["SYSTEM-F" D SNDERR W XWBERR
IF XWBOS'="DSM" D G RESTART
. D SNDERR W XWBERR
S $ECODE=",U1," Q ;Pass error up to pop stack.
;
SNDERR ;send error information
;XWBSEC is the security packet, XWBERROR is application packet
N X
S X=$G(XWBSEC)
W $C($L(X))_X
S X=$G(XWBERROR)
W $C($L(X))_X W !
S XWBERROR="" ;clears parameters
Q
;
;
UPDTREC(XWBTSKT,STATE,XWBENV) ; -- update STATUS field and ^%ZIS X-ref of the
;RPC BROKER SITE PARAMETER file
;XWBTSKT: listener port
N C,XWBOXIEN,XWBPOIEN,XWBFDA
S C=",",U="^"
I $G(XWBENV)'="" S Y=XWBENV
E D GETENV^%ZOSV ;get Y=UCI^VOL^NODE^BOXLOOKUP of current system
I STATE=3 S ^%ZIS(8994.171,"RPCB Listener",$P(Y,U,2),$P(Y,U),$P(Y,U,4),XWBTSKT)=$J
I STATE=6 K ^%ZIS(8994.171,"RPCB Listener",$P(Y,U,2),$P(Y,U),$P(Y,U,4),XWBTSKT)
;
S XWBOXIEN=$$FIND1^DIC(8994.17,",1,","",$P(Y,U,4)) ;find rec for box
S XWBPOIEN=$$FIND1^DIC(8994.171,C_XWBOXIEN_",1,","",XWBTSKT)
D:XWBPOIEN>0 ;update STATUS field if entry was found
. D FDA^DILF(8994.171,XWBPOIEN_C_XWBOXIEN_C_1_C,1,"R",STATE,"XWBFDA")
. D FILE^DIE("","XWBFDA")
Q
;
;
SEMAPHOR(XWBTSKT,XWBACT) ;Lock/Unlock listener semaphore
;XWBTSKT: listener port, XWBACT: "LOCK" | "UNLOCK" action to perform
;if LOCK is requested, it will be attempted with 1 sec timeout and if
;lock was obtained RESULT will be 1, otherwise it will be 0. For
;unlock RESULT will always be 1.
N RESULT
S U="^",RESULT=1
D GETENV^%ZOSV ;get Y=UCI^VOL^NODE^BOXLOOKUP of current system
I XWBACT="LOCK" D
. L +^%ZIS(8994.171,"RPCB Listener",$P(Y,U,2),$P(Y,U),$P(Y,U,4),XWBTSKT):1
. S RESULT=$T
E L -^%ZIS(8994.171,"RPCB Listener",$P(Y,U,2),$P(Y,U),$P(Y,U,4),XWBTSKT)
Q RESULT
XWBTCPL ;SLC/KCM - Listener for TCP connects [ 02/13/95 9:01 PM ] ;10/16/96 11:33
+1 ;;1.1T3;RPC BROKER;;Nov 25, 1996
+2 ;ISC-SF/EG - DHCP Broker
+3 ;
+4 ; This routine is the background process that listens for client
+5 ; requests to connect to M. When a request is received, This
+6 ; procedure will job a s small routine to listen for new requests
+7 ; on the known service port.
+8 ;
+9 ; This job may be started in the background with: D STRT^XWBTCP(PORT)
+10 ;
+11 ; When running, this job may be stopped with: D STOP^XWBTCP(PORT)
+12 ;
+13 ; Where port is the known service port to listen for connections
+14 ;
EN(XWBTSKT) ; -- accept clients and start the individual message handler
+1 NEW IP,REF,RETRY,XWBVER
+2 SET U="^"
+3 SET RETRY="START"
+4 XECUTE ^%ZOSF("UCI")
SET REF=Y
+5 ;get server IP
SET IP="0.0.0.0"
+6 ; default service port
IF $GET(XWBTSKT)=""
SET XWBTSKT=9000
+7 SET XWBTDEV=XWBTSKT
+8 ;
+9 ;change process name
DO SETNM^%ZOSV($EXTRACT("RPCB_Port:"_XWBTSKT,1,15))
+10 NEW LEN,MSG,XWBOS,DONE,DSMTCP,X
+11 ; -- check the TCP stop parameter
+12 ;IF $G(^XWB(IP,REF,XWBTSKT,"STOP")) K ^XWB(IP,REF,XWBTSKT) Q ; -- change to param file later ***
+13 ; -- quit if job is already running
IF '$$SEMAPHOR(XWBTSKT,"LOCK")
QUIT
+14 ;
+15 ;updt RPC BROKER SITE PARAMETER record as RUNNING
DO UPDTREC(XWBTSKT,3)
+16 ;
RESTART ;
+1 SET DONE=0
+2 SET XWBOS=$SELECT(^%ZOSF("OS")["DSM":"DSM",^("OS")["MSM":"MSM",^("OS")["OpenM":"OpenM",1:"")
+3 IF $$NEWERR^%ZTER
NEW $ESTACK
SET $ETRAP="S %ZTER11S=$STACK D ETRAP^XWBTCPL"
+4 IF '$TEST
SET X="ETRAP^XWBTCPL"
SET @^%ZOSF("TRAP")
+5 ;
+6 ; -- check the TCP stop parameter
+7 ;IF $G(^XWB(IP,REF,XWBTSKT,"STOP")) K ^XWB(IP,REF,XWBTSKT) Q ; -- change to param file later ***
+8 ;
+9 ;Open listener
IF XWBOS="DSM"
OPEN XWBTSKT:TCPCHAN:5
+10 ; -- loop until TCP stop parameter is set
+11 ;F D Q:$G(^XWB(IP,REF,XWBTSKT,"STOP"))
+12 FOR
Begin DoDot:1
+13 LOCK +^XWB(IP,REF,XWBTSKT,"PROBLEM MARKER")
+14 ;clear problem marker
KILL ^XWB(IP,REF,XWBTSKT,"PROBLEM MARKER")
+15 LOCK -^XWB(IP,REF,XWBTSKT,"PROBLEM MARKER")
+16 ;
+17 ; -- listen for connect & get the initial message from the client
+18 IF XWBOS="DSM"
USE XWBTSKT
+19 IF XWBOS="MSM"
SET XWBTDEV=56
OPEN 56
USE 56::"TCP"
WRITE /SOCKET("",XWBTSKT)
+20 IF XWBOS="OpenM"
SET XWBTDEV="|TCP|"_XWBTSKT
OPEN XWBTDEV:(:XWBTSKT:"AT")
USE XWBTDEV
READ *X
+21 SET XWBVER=0
+22 READ LEN#11
IF $EXTRACT(LEN,1,5)'="{XWB}"
QUIT
+23 IF $EXTRACT(LEN,11,11)="|"
Begin DoDot:2
+24 READ X#1
+25 READ XWBVER#$ASCII(X)
+26 READ LEN#5
+27 READ MSG#LEN
End DoDot:2
+28 IF '$TEST
SET X=$EXTRACT(LEN,11,11)
SET LEN=$EXTRACT(LEN,6,10)-1
READ MSG#LEN
SET MSG=X_MSG
+29 ; -- msg should be: action^client IP^client port^token
+30 ;
+31 ; -- if the action is TCPconnect (usual case)
+32 IF $PIECE(MSG,"^")="TCPconnect"
Begin DoDot:2
+33 ;-- decrypt token
+34 NEW X,%T
SET X=""
SET %T=0
+35 IF XWBOS="DSM"
JOB EN^XWBTCPC($PIECE(MSG,"^",2),$PIECE(MSG,"^",3),$PIECE(X,"^"),XWBVER):OPTION="/SYMBOL=100000":5
SET %T=$TEST
+36 IF XWBOS="MSM"
JOB EN^XWBTCPC($PIECE(MSG,"^",2),$PIECE(MSG,"^",3),$PIECE(X,"^"),XWBVER):100000:5
SET %T=$TEST
+37 IF XWBOS="OpenM"
JOB EN^XWBTCPC($PIECE(MSG,"^",2),$PIECE(MSG,"^",3),$PIECE(X,"^"),XWBVER)::5
SET %T=$TEST
+38 IF %T
DO SNDERR
WRITE "accept",$CHAR(4),!
+39 IF '$TEST
DO SNDERR
WRITE "reject",$CHAR(4),!
SET ^TMP("TCP",$PIECE($HOROLOG,",",2))="REJECT"
End DoDot:2
+40 ;
+41 ; -- if the action is TCPdebug (when msg handler run interactively)
+42 IF $PIECE(MSG,"^")="TCPdebug"
DO SNDERR
WRITE "accept",$CHAR(4),!
+43 ;
+44 ; -- if the action is TCPshutdown, this listener will quit if the
+45 ; stop flag has been set. This request comes from an M process.
+46 IF $PIECE(MSG,"^")="TCPshutdown"
SET DONE=1
WRITE "ack",!
+47 ;Now release the connection.
+48 ; release this socket
IF XWBOS="DSM"
USE XWBTSKT:DISCONNECT
+49 IF XWBOS="MSM"
CLOSE 56
+50 IF XWBOS="OpenM"
CLOSE XWBTDEV
+51 QUIT
End DoDot:1
IF DONE
QUIT
+52 ; -- loop end
+53 ;
+54 IF XWBOS="DSM"
CLOSE XWBTSKT
+55 ; destroy 'running flag'
SET %=$$SEMAPHOR(XWBTSKT,"UNLOCK")
+56 ;K ^XWB(IP,REF,XWBTSKT,"STOP")
+57 ;updt RPC BROKER SITE PARAMETER record as STOPPED
DO UPDTREC(XWBTSKT,6)
+58 QUIT
+59 ;
ETRAP ; -- on trapped error, send error info to client
+1 NEW XWBERR
+2 SET XWBERR=$CHAR(24)_"M ERROR="_$ZERROR_$CHAR(13,10)_"LAST REF="_$ZR_$CHAR(4)
+3 ;Record it
DO ^%ZTER
+4 SET RETRY=RETRY+1
HANG 3
+5 ;give up trying, server should not restart
IF RETRY=5
HANG
+6 IF $$NEWERR^%ZTER
SET $ETRAP="Q:($ESTACK&'$QUIT) Q:$ESTACK 0 S $ECODE="""" G RESTART^XWBTCPL"
+7 IF XWBOS="DSM"
Begin DoDot:1
+8 IF $DATA(XWBTLEN)
IF XWBTLEN
IF $ZE'["SYSTEM-F"
DO SNDERR
WRITE XWBERR
End DoDot:1
+9 IF XWBOS'="DSM"
Begin DoDot:1
+10 DO SNDERR
WRITE XWBERR
End DoDot:1
GOTO RESTART
+11 ;Pass error up to pop stack.
SET $ECODE=",U1,"
QUIT
+12 ;
SNDERR ;send error information
+1 ;XWBSEC is the security packet, XWBERROR is application packet
+2 NEW X
+3 SET X=$GET(XWBSEC)
+4 WRITE $CHAR($LENGTH(X))_X
+5 SET X=$GET(XWBERROR)
+6 WRITE $CHAR($LENGTH(X))_X
WRITE !
+7 ;clears parameters
SET XWBERROR=""
+8 QUIT
+9 ;
+10 ;
UPDTREC(XWBTSKT,STATE,XWBENV) ; -- update STATUS field and ^%ZIS X-ref of the
+1 ;RPC BROKER SITE PARAMETER file
+2 ;XWBTSKT: listener port
+3 NEW C,XWBOXIEN,XWBPOIEN,XWBFDA
+4 SET C=","
SET U="^"
+5 IF $GET(XWBENV)'=""
SET Y=XWBENV
+6 ;get Y=UCI^VOL^NODE^BOXLOOKUP of current system
IF '$TEST
DO GETENV^%ZOSV
+7 IF STATE=3
SET ^%ZIS(8994.171,"RPCB Listener",$PIECE(Y,U,2),$PIECE(Y,U),$PIECE(Y,U,4),XWBTSKT)=$JOB
+8 IF STATE=6
KILL ^%ZIS(8994.171,"RPCB Listener",$PIECE(Y,U,2),$PIECE(Y,U),$PIECE(Y,U,4),XWBTSKT)
+9 ;
+10 ;find rec for box
SET XWBOXIEN=$$FIND1^DIC(8994.17,",1,","",$PIECE(Y,U,4))
+11 SET XWBPOIEN=$$FIND1^DIC(8994.171,C_XWBOXIEN_",1,","",XWBTSKT)
+12 ;update STATUS field if entry was found
IF XWBPOIEN>0
Begin DoDot:1
+13 DO FDA^DILF(8994.171,XWBPOIEN_C_XWBOXIEN_C_1_C,1,"R",STATE,"XWBFDA")
+14 DO FILE^DIE("","XWBFDA")
End DoDot:1
+15 QUIT
+16 ;
+17 ;
SEMAPHOR(XWBTSKT,XWBACT) ;Lock/Unlock listener semaphore
+1 ;XWBTSKT: listener port, XWBACT: "LOCK" | "UNLOCK" action to perform
+2 ;if LOCK is requested, it will be attempted with 1 sec timeout and if
+3 ;lock was obtained RESULT will be 1, otherwise it will be 0. For
+4 ;unlock RESULT will always be 1.
+5 NEW RESULT
+6 SET U="^"
SET RESULT=1
+7 ;get Y=UCI^VOL^NODE^BOXLOOKUP of current system
DO GETENV^%ZOSV
+8 IF XWBACT="LOCK"
Begin DoDot:1
+9 LOCK +^%ZIS(8994.171,"RPCB Listener",$PIECE(Y,U,2),$PIECE(Y,U),$PIECE(Y,U,4),XWBTSKT):1
+10 SET RESULT=$TEST
End DoDot:1
+11 IF '$TEST
LOCK -^%ZIS(8994.171,"RPCB Listener",$PIECE(Y,U,2),$PIECE(Y,U),$PIECE(Y,U,4),XWBTSKT)
+12 QUIT RESULT
