| 1 | XWBTCPL ;SLC/KCM - Listener for TCP connects ;08/25/2004 12:08
|
|---|
| 2 | ;;1.1;RPC BROKER;**1,7,9,15,16,35**;Mar 28, 1997
|
|---|
| 3 | ;ISC-SF/EG - DHCP Broker
|
|---|
| 4 | ;
|
|---|
| 5 | ; This routine is the background process that listens for client
|
|---|
| 6 | ; requests to connect to M. When a request is received, This
|
|---|
| 7 | ; procedure will job a routine to handle the requests of the client.
|
|---|
| 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 | ; p*35 Moved reads and writes to XWBRW
|
|---|
| 15 | ;
|
|---|
| 16 | EN(XWBTSKT) ; -- accept clients and start the individual message handler
|
|---|
| 17 | N $ETRAP,$ESTACK S $ETRAP="D ^%ZTER J EN^XWBTCPL($G(XWBTSKT)) HALT"
|
|---|
| 18 | N RETRY,X,XWBVER,XWBVOL,LEN,MSG,XWBOS,DONE,DSMTCP,NATIP,XWBRBUF
|
|---|
| 19 | N XWBTIME
|
|---|
| 20 | S U="^",RETRY="START"
|
|---|
| 21 | X ^%ZOSF("UCI") S XWBVOL=$P(Y,",",2) ;(*p7,p9*)
|
|---|
| 22 | IF $G(XWBTSKT)="" S XWBTSKT=9000 ; default service port
|
|---|
| 23 | S XWBTDEV=XWBTSKT
|
|---|
| 24 | ;
|
|---|
| 25 | Q:'$$SEMAPHOR(XWBTSKT,"LOCK") ; -- quit if job is already running
|
|---|
| 26 | ;
|
|---|
| 27 | S XWBDEBUG=$$GET^XPAR("SYS","XWBDEBUG") ;(*p35)
|
|---|
| 28 | I XWBDEBUG D LOGSTART^XWBDLOG("XWBTCPL") ;(*p35)
|
|---|
| 29 | D UPDTREC(XWBTSKT,3) ;updt RPC BROKER SITE PARAMETER record as RUNNING
|
|---|
| 30 | D MARKER^XWBTCP(XWBTSKT,-1) ;Clear marker
|
|---|
| 31 | ;
|
|---|
| 32 | D SETNM^%ZOSV($E("RPCB_Port:"_XWBTSKT,1,15)) ;change process name
|
|---|
| 33 | ;
|
|---|
| 34 | RESTART ;
|
|---|
| 35 | H 5 ;Hibernate so caller can clear (*p16,*p35)
|
|---|
| 36 | N $ESTACK S $ETRAP="D ETRAP^XWBTCPL"
|
|---|
| 37 | S DONE=0,X=0,XWBTIME=5,XWBTIME(1)=5
|
|---|
| 38 | S XWBOS=$S(^%ZOSF("OS")["DSM":"DSM",^("OS")["OpenM":"OpenM",^("OS")["GT.M":"GTM",^("OS")["MSM":"MSM",1:"")
|
|---|
| 39 | S XWBT("BF")=$S(XWBOS="GT.M":"#",1:"!") ;(*p35)
|
|---|
| 40 | ;
|
|---|
| 41 | S %T=0 ;Check for Open success (*p35)
|
|---|
| 42 | ;DSM
|
|---|
| 43 | I XWBOS="DSM" O XWBTSKT:TCPCHAN:5 S %T=$T ;Open listener
|
|---|
| 44 | ;Cache, Terminator = $C(4)512 buffers, queue = 10
|
|---|
| 45 | I XWBOS="OpenM" S XWBTDEV="|TCP|"_XWBTSKT O XWBTDEV:(:XWBTSKT:"A":$C(4):512:512:10):5 S %T=$T ;(*p35)
|
|---|
| 46 | ;GT.M (*p35)
|
|---|
| 47 | I XWBOS="GTM" D
|
|---|
| 48 | . S @("$ZINTERRUPT=""I $$JOBEXAM^ZU($ZPOSITION)""")
|
|---|
| 49 | . S XWBTDEV="SKD$"_$J,XWBTSKT=XWBTSKT
|
|---|
| 50 | . O XWBTDEV:(ZLISTEN=XWBTSKT_":TCP":NODELIMITER:ATTACH="listener"):5:"SOCKET" S %T=$T Q:'%T
|
|---|
| 51 | . U XWBTDEV S XWBTDEV("LISTENER")=$KEY
|
|---|
| 52 | . W /LISTEN(1)
|
|---|
| 53 | . U XWBTDEV S XWBTDEV("STATUS")=$KEY
|
|---|
| 54 | . Q
|
|---|
| 55 | ;Check if got device Open
|
|---|
| 56 | I '%T D LOG^XWBDLOG("Open "_XWBTSKT_" Fail") Q ;(*p35)
|
|---|
| 57 | ;
|
|---|
| 58 | I XWBDEBUG D LOG^XWBDLOG("Port Open: "_XWBTSKT)
|
|---|
| 59 | F D Q:DONE
|
|---|
| 60 | . S DONE=0
|
|---|
| 61 | . ; -- listen for connect & get the initial message from the client
|
|---|
| 62 | . I XWBOS="DSM" U XWBTSKT S XWBTIME=60 ;Will wait at read
|
|---|
| 63 | . I XWBOS="MSM" S XWBTDEV=56 O 56 U 56::"TCP" W /SOCKET("",XWBTSKT)
|
|---|
| 64 | . I XWBOS="OpenM" U XWBTDEV R *X ;Cache will wait here for connection
|
|---|
| 65 | . I XWBOS="GTM" D
|
|---|
| 66 | . . K XWBTDEV("SOCKET")
|
|---|
| 67 | . . F D Q:$D(XWBTDEV("SOCKET"))
|
|---|
| 68 | . . . ;Wait for connection, $KEY will be "CONNECT|socket_handle|remote_ipaddress"
|
|---|
| 69 | . . . U XWBTDEV W /WAIT(10) S XWBTDEV("KEY")=$KEY
|
|---|
| 70 | . . . I XWBTDEV("KEY")="" Q
|
|---|
| 71 | . . . S XWBTDEV("SOCKET")=$P(XWBTDEV("KEY"),"|",2)
|
|---|
| 72 | . . . S (XWBTDEV("IP"),IO("GTM-IP"))=$P(XWBTDEV("KEY"),"|",3)
|
|---|
| 73 | . . . U XWBTDEV:(SOCKET=XWBTDEV("SOCKET"):WIDTH=512:NOWRAP:EXCEPTION="GOTO ETRAP")
|
|---|
| 74 | . . . Q
|
|---|
| 75 | . . Q
|
|---|
| 76 | . ;========================MAIN LOOP=======================
|
|---|
| 77 | . ;(*p35) change to use MSG, MSG1 and MSG2
|
|---|
| 78 | . S (MSG,MSG1,MSG2,XWBRBUF)=""
|
|---|
| 79 | . ;F XCNT=0:0 R MSG1#1:XWBTIME Q:$T I '$T S XCNT=XCNT+1 Q:XCNT>5
|
|---|
| 80 | . F XCNT=0:0 S MSG1=$$BREAD^XWBRW(1,XWBTIME,1) Q:$L(MSG1) S XCNT=XCNT+1 Q:XCNT>5
|
|---|
| 81 | . Q:XCNT>5
|
|---|
| 82 | . I MSG1'="{" D RELEASE(0) Q ;Not the right start so Close.
|
|---|
| 83 | . S MSG1=MSG1_$$BREAD^XWBRW(4,,1) IF (MSG1'="{XWB}") D RELEASE(0) Q
|
|---|
| 84 | . S MSG1=MSG1_$$BREAD^XWBRW(6)
|
|---|
| 85 | . I $E(MSG1,11)="|" D
|
|---|
| 86 | . . S VL=$$BREAD^XWBRW(1),VL=$A(VL)
|
|---|
| 87 | . . S XWBVER=$$BREAD^XWBRW(VL)
|
|---|
| 88 | . . S LEN=$$BREAD^XWBRW(5)
|
|---|
| 89 | . . S MSG=$$BREAD^XWBRW(+LEN)
|
|---|
| 90 | . E S X=$E(MSG1,11),LEN=$E(MSG1,6,10)-1,MSG2=$$BREAD^XWBRW(LEN),MSG=X_MSG2,XWBVER=0
|
|---|
| 91 | . ; -- msg should be: action^client IP^client port^token
|
|---|
| 92 | . I XWBDEBUG D LOG^XWBDLOG("Hdr:"_MSG1_" Msg:"_MSG) ;(*p35)
|
|---|
| 93 | . ;
|
|---|
| 94 | . ; -- if the action is TCPconnect (usual case)
|
|---|
| 95 | . I $P(MSG,"^")="TCPconnect" D
|
|---|
| 96 | . . N DZ,%T S DZ="",%T=0,RETRY=$S($G(RETRY)>1:RETRY-1,1:0) ;(*p7*)
|
|---|
| 97 | . . ;Get the peer and use that IP, Allow use thru a NAT box.
|
|---|
| 98 | . . S NATIP=$$GETPEER^%ZOSV I $L(NATIP) S $P(MSG,"^",2)=NATIP ;(*p35)
|
|---|
| 99 | . . I '$$NEWJOB D QSND("reject") Q ;(*p7,*p35)
|
|---|
| 100 | . . I XWBDEBUG>1 D LOG^XWBDLOG("JOB: "_MSG)
|
|---|
| 101 | . . ;Job a Server, X should be null
|
|---|
| 102 | . . J EN^XWBTCPC($P(MSG,"^",2),$P(MSG,"^",3),$P(DZ,"^"),XWBVER,$P(MSG,"^",4))::5 S %T=$T
|
|---|
| 103 | . . I %T D QSND("accept") ;(*p35)
|
|---|
| 104 | . . I '%T D QSND("reject") ;(*p35)
|
|---|
| 105 | . ;
|
|---|
| 106 | . ; -- if the action is TCPdebug (when msg handler run interactively)
|
|---|
| 107 | . I $P(MSG,"^")="TCPdebug" D QSND("accept") ;(*p35)
|
|---|
| 108 | . ;
|
|---|
| 109 | . ; -- if the action is TCPshutdown, this listener will quit if the
|
|---|
| 110 | . ; stop flag has been set. This request comes from an M process.
|
|---|
| 111 | . I $P(MSG,"^")="TCPshutdown" S DONE=1 D QSND^XWBRW("ack")
|
|---|
| 112 | . D RELEASE(0) ;Now release the connection. (*p7*)
|
|---|
| 113 | . Q
|
|---|
| 114 | ; -- loop end
|
|---|
| 115 | ;
|
|---|
| 116 | S %=$$SEMAPHOR(XWBTSKT,"UNLOCK") ; destroy 'running flag'
|
|---|
| 117 | D LOG^XWBDLOG("Exit")
|
|---|
| 118 | D UPDTREC(XWBTSKT,6) ;updt RPC BROKER SITE PARAMETER record as STOPPED
|
|---|
| 119 | S $ETRAP="" ;(*p35) Turn off error trap
|
|---|
| 120 | IF XWBOS="DSM" C XWBTSKT ;Do Close last in case it gets an error
|
|---|
| 121 | Q
|
|---|
| 122 | ;
|
|---|
| 123 | QSND(STR) ;Write output (*p35)
|
|---|
| 124 | D QSND^XWBRW(STR),LOG^XWBDLOG(STR)
|
|---|
| 125 | Q
|
|---|
| 126 | ;
|
|---|
| 127 | ETRAP ; -- on trapped error, send error info to client
|
|---|
| 128 | N XWBERC,XWBERR S $ETRAP="D ^%ZTER J EN^XWBTCPL($G(XWBTSKT)) HALT"
|
|---|
| 129 | S XWBERC=$$EC^%ZOSV,XWBERR=$C(24)_"M ERROR="_XWBERC_$C(13,10)_"LAST REF="_$$LGR^%ZOSV
|
|---|
| 130 | D ^%ZTER ;Record error and clear $ECODE
|
|---|
| 131 | D LOG^XWBDLOG("Error: "_$E(XWBERC,1,200))
|
|---|
| 132 | S RETRY=$G(RETRY)+1 H 3+(RETRY\5) ;(*p7*) Slow down but never stop
|
|---|
| 133 | ;Halt if DSM DUPNAME
|
|---|
| 134 | I XWBERC["F-DUPLNAM" D HALT
|
|---|
| 135 | . S %=$$SEMAPHOR(XWBTSKT,"UNLOCK") ; destroy 'running flag'
|
|---|
| 136 | . D UPDTREC(XWBTSKT,6) ;updt RPC BROKER SITE PARAMETER record as STOPPED
|
|---|
| 137 | . Q
|
|---|
| 138 | ;Set new trap
|
|---|
| 139 | S $ETRAP="Q:($ESTACK&'$QUIT) Q:$ESTACK -9 S $ECODE="""" G RESTART^XWBTCPL"
|
|---|
| 140 | ;
|
|---|
| 141 | I (XWBERC["READ")!(XWBERC["WRITE")!(XWBERC["SYSTEM-F") G ETRAPX
|
|---|
| 142 | IF XWBOS="DSM" D
|
|---|
| 143 | . I $D(XWBTLEN),XWBTLEN,XWBERC'["SYSTEM-F" D QSND(XWBERR) ;(p35)
|
|---|
| 144 | IF XWBOS="OpenM",XWBERC'["<WRITE>" D QSND(XWBERR) ;(*p7,35*)
|
|---|
| 145 | IF XWBOS="MSM" D QSND(XWBERR) ;(*p7,35*)
|
|---|
| 146 | ETRAPX D RELEASE(1) ;Now close the connection. (*p7*)
|
|---|
| 147 | I XWBOS="DSM" H 15 ;Wait for device to close
|
|---|
| 148 | S $ECODE=",U1," Q ;Pass error up to pop stack.
|
|---|
| 149 | ;
|
|---|
| 150 | FLUSH ;Flush the input buffer
|
|---|
| 151 | F R X:0 Q:'$T
|
|---|
| 152 | Q
|
|---|
| 153 | ;
|
|---|
| 154 | RELEASE(%) ;Now release the connection. (*p7*)
|
|---|
| 155 | ;Parameter is zero to Release, one to Close
|
|---|
| 156 | I XWBOS="DSM" D Q ;(*p35)
|
|---|
| 157 | . I $G(%) C XWBTSKT Q
|
|---|
| 158 | . U XWBTSKT:DISCONNECT ; release this socket
|
|---|
| 159 | I XWBOS="OpenM" D Q ;(*p35)
|
|---|
| 160 | . I $G(%) C XWBTDEV Q
|
|---|
| 161 | . W *-2 ;Release the socket
|
|---|
| 162 | I XWBOS="GTM" D Q ;(*p35)
|
|---|
| 163 | . I $G(%) C XWBTDEV Q
|
|---|
| 164 | . C XWBTDEV:(SOCKET=XWBTDEV("SOCKET")) ;release the socket
|
|---|
| 165 | I XWBOS="MSM" C 56
|
|---|
| 166 | Q
|
|---|
| 167 | ;
|
|---|
| 168 | UPDTREC(XWBTSKT,STATE,XWBENV) ; -- update STATUS field and ^%ZIS X-ref of the
|
|---|
| 169 | ;RPC BROKER SITE PARAMETER file
|
|---|
| 170 | ;XWBTSKT: listener port
|
|---|
| 171 | N C,XWBOXIEN,XWBPOIEN,XWBFDA
|
|---|
| 172 | S C=",",U="^"
|
|---|
| 173 | I $G(XWBENV)'="" S Y=XWBENV
|
|---|
| 174 | E D GETENV^%ZOSV ;get Y=UCI^VOL^NODE^BOXLOOKUP of current system
|
|---|
| 175 | ;I STATE=3 S ^%ZIS(8994.171,"RPCB Listener",$P(Y,U,2),$P(Y,U),$P(Y,U,4),XWBTSKT)=$J
|
|---|
| 176 | ;I STATE=6 K ^%ZIS(8994.171,"RPCB Listener",$P(Y,U,2),$P(Y,U),$P(Y,U,4),XWBTSKT)
|
|---|
| 177 | ;
|
|---|
| 178 | S XWBOXIEN=$$FIND1^DIC(8994.17,",1,","",$P(Y,U,4)) ;find rec for box
|
|---|
| 179 | S XWBPOIEN=$$FIND1^DIC(8994.171,C_XWBOXIEN_",1,","",XWBTSKT)
|
|---|
| 180 | D:XWBPOIEN>0 ;update STATUS field if entry was found
|
|---|
| 181 | . D FDA^DILF(8994.171,XWBPOIEN_C_XWBOXIEN_C_1_C,1,"R",STATE,"XWBFDA")
|
|---|
| 182 | . D FILE^DIE("","XWBFDA")
|
|---|
| 183 | Q
|
|---|
| 184 | ;
|
|---|
| 185 | ;
|
|---|
| 186 | SEMAPHOR(XWBTSKT,XWBACT) ;Lock/Unlock listener semaphore
|
|---|
| 187 | ;XWBTSKT: listener port, XWBACT: "LOCK" | "UNLOCK" action to perform
|
|---|
| 188 | ;if LOCK is requested, it will be attempted with 1 sec timeout and if
|
|---|
| 189 | ;lock was obtained RESULT will be 1, otherwise it will be 0. For
|
|---|
| 190 | ;unlock RESULT will always be 1.
|
|---|
| 191 | N RESULT
|
|---|
| 192 | S U="^",RESULT=1
|
|---|
| 193 | D GETENV^%ZOSV ;get Y=UCI^VOL^NODE^BOXLOOKUP of current system
|
|---|
| 194 | I XWBACT="LOCK" D
|
|---|
| 195 | . L +^%ZIS(8994.171,"RPCB Listener",$P(Y,U,2),$P(Y,U),$P(Y,U,4),XWBTSKT):1
|
|---|
| 196 | . S RESULT=$T
|
|---|
| 197 | E L -^%ZIS(8994.171,"RPCB Listener",$P(Y,U,2),$P(Y,U),$P(Y,U,4),XWBTSKT)
|
|---|
| 198 | Q RESULT
|
|---|
| 199 | ;
|
|---|
| 200 | NEWJOB() ;Check if OK to start a new job, Return 1 if OK, 0 if not OK.
|
|---|
| 201 | N X,Y,XQVOL,XUVOL
|
|---|
| 202 | S X=$O(^XTV(8989.3,1,4,"B",XWBVOL,0)),XUVOL=$S(X>0:^XTV(8989.3,1,4,X,0),1:"ROU^y^1"),XQVOL=XWBVOL
|
|---|
| 203 | S X=$$INHIBIT^XUSRB ;Returns 1 if new logons are inhibited.
|
|---|
| 204 | Q 'X
|
|---|
