source: WorldVistAEHR/trunk/r/RPC_BROKER-XWB/XWBTCPL.m@ 1042

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

initial load of WorldVistAEHR

File size: 8.1 KB
Line 
1XWBTCPL ;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 ;
16EN(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 ;
34RESTART ;
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 ;
123QSND(STR) ;Write output (*p35)
124 D QSND^XWBRW(STR),LOG^XWBDLOG(STR)
125 Q
126 ;
127ETRAP ; -- 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*)
146ETRAPX 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 ;
150FLUSH ;Flush the input buffer
151 F R X:0 Q:'$T
152 Q
153 ;
154RELEASE(%) ;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 ;
168UPDTREC(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 ;
186SEMAPHOR(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 ;
200NEWJOB() ;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
Note: See TracBrowser for help on using the repository browser.