COMMENT ⊗   VALID 00014 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00003 00002	TITLE SUNSER
C00005 00003	TERMID CORBEG TERSTR NETCMP RCBINP TRBINP ECHOP SUPGAP FLSCHP PUPIBH PUPOBH GOTINT PDL COREND RFCBLK SUNSKT SUNHST SMRBLK RMRBLK INPBLK
C00008 00004	TPLTAB TPLMIN WDOTAB WDOMAX EXOPL
C00011 00005	SUNSER
C00013 00006	CPYHST 1DIGTP NOTTIP
C00015 00007	GETHSN BADHST GETSKT GETSKN BADSKT
C00017 00008	PUPICP
C00019 00009	NETSER NETSR1
C00021 00010	PUPSER PUPSR1 PUPSR2 PUPSR3
C00024 00011	IACSER PRSTAB WHOLIN
C00026 00012	DOSR DONTSR
C00028 00013	WILLSR WONTSR
C00029 00014	OPTMSG RNDMSG SNDMSG MSGLUP SUICID DEATH ...LIT SVRRTS ERRTNS ERRHAN ERRINS HSTTAB HSTSIX
C00031 ENDMK
C⊗;
TITLE SUNSER
SUBTTL Mark Crispin, SU-AI, October 1981

; Assembly switches

IFNDEF SVRSKT,SVRSKT==131	; default listen socket
IFNDEF CHTSKT,CHTSKT==1		; default Chat socket
IFNDEF LOKTMO,LOKTMO==5		; # of 15-second frobs of lock timeout
IFNDEF PDLLEN,PDLLEN==50	; stack length

; AC definitions.  0→3 are used by NETWRK

X=4 ? A=5 ? B=6 ? C=7 ? P=17

PUP==2				; Pup's I/O channel (NETWRK uses 0 and 1)

; Macro to send a TELNET command

DEFINE TELCMD CMDLST
 OUTSTR [ASCIZ/⊗!CMDLST!*
/]
 IRPS CMD,,CMDLST
  MOVEI CMD
  PUSHJ P,NETOCH
 TERMIN
 PUSHJ P,NETSND
TERMIN

; SAIL system bit definitions

INTCLK==000200,,		; clock interrupt
INTIMS==000020,,		; status change interrupt
INTINP==000010,,		; input interrupt
IODTER==100000			; timeout
IOBKTL==040000			; block too large
IODEND==020000			; End seen
INTBTS==INTCLK\INTINP\INTIMS
;TERMID CORBEG TERSTR NETCMP RCBINP TRBINP ECHOP SUPGAP FLSCHP PUPIBH PUPOBH GOTINT PDL COREND RFCBLK SUNSKT SUNHST SMRBLK RMRBLK INPBLK

; Terminal location string

TERMID:	'TERMID

CORBEG==.			; start of initialized core storage

TERSTR:	BLOCK 10.		; console location string

; Protocol flags

NETCMP:	BLOCK 1			; -1 → IAC in progress

IRPS OPT,,WILL WONT DO DONT
 OPT!P:	BLOCK 1			; -1 → option in effect
TERMIN

RCBINP:	BLOCK 1			; -1 → receiving binary
TRBINP:	BLOCK 1			; -1 → transmitting binary
ECHOP:	BLOCK 1			; -1 → remote echoing
SUPGAP:	BLOCK 1			; -1 → suppressing GA
FLSCHP:	BLOCK 1			; -1 → flush next character

; Other storage

PUPIBH:	BLOCK 3			; Pup input buffer header
PUPOBH:	BLOCK 3			; Pup output buffer header
GOTINT:	BLOCK 1			; -1 → got an interrupt
PDL:	BLOCK PDLLEN		; stack

COREND==.-1			; end of initialized storage

RFCBLK:	0			; connect to remote host
	0			; status word
	0			; socket number (1 for TELNET)
	-1			; wait flag
	8			; byte size
SUNSKT:	1			; foreign socket number
SUNHST:	0			; host

SMRBLK:	25			; send Mark
	0			; status word
	6			; Timing Mark Reply

RMRBLK:	26			; read last Mark
	0			; status word
	0			; Mark type returned here

INPBLK:	10			; skip if input available
	0			; status word

;TPLTAB TPLMIN WDOTAB WDOMAX EXOPL

DEFINE TPC CODE
 CODE
 IRPS NAME,,CODE
  [ASCIZ/NAME/]
 .ISTOP
 TERMIN
TERMIN

; Protocol codes

TPLTAB:
 TPC SE==360			; subnegotiation end
 TPC NOP==361			; no-op
 TPC DM==362			; data mark
 TPC BRK==363			; break key
 TPC IP==364			; interrupt process
 TPC AO==365			; abort output
 TPC AYT==366			; are you there?
 TPC EC==367			; erase character
 TPC EL==370			; erase line
 TPC GA==371			; go ahead
 TPC SB==372			; subnegotiation
 TPC WILL==373			; sender will do
 TPC WONT==374			; sender won't do
 TPC DO==375			; receiver asked to do
 TPC DONT==376			; receiver must not do
 TPC IAC==377			; interpret as command
TPLMIN==400-<.-TPLTAB>

; WILL/WONT/DO/DONT codes

WDOTAB:
 TPC TRNBIN==0			; transmit binary
 TPC ECHO==1			; echo
 TPC RCP==2			; reconnect
 TPC SUPRGA==3			; suppress GA
 TPC NAMS==4			; negotiate approx. message size
 TPC STATUS==5			; status option
 TPC TIMMRK==6			; timing mark
 TPC RCTE==7			; remote controlled trans/echo
 TPC NAOL==10			; negotiate output line width
 TPC NAOP==11			; negotiate page size
 TPC NAOCRD==12			; negotiate output CR
 TPC NAOHTS==13			; negotiate output horizontal tab stops
 TPC NAOHTD==14			; negotiate output HT
 TPC NAOFFD==15			; negotiate output FF
 TPC NAOVTS==16			; negotiate output vertical tab stops
 TPC NAOVTD==17			; negotiate output VT
 TPC NAOLFD==20			; negotiate output LF
 TPC EXTASC==21			; Tovar's cretinous idea of extended ASCII
 TPC LOGOUT==22			; logout option
 TPC BM==23			; byte macro
 TPC DET==24			; data entry terminal option
 TPC SUPDUP==25			; SUPDUP (not TELNET) protocol
 TPC SDOTPT==26			; SUPDUP output option
WDOMAX==.-WDOTAB-1

EXOPL==377			; extended options (great idea Postel)
;SUNSER

SUNSER:	TRN
	RESET
	MOVE ['SUNSER]		; set our name
	SETNAM
	SETZM CORBEG		; initialize core
	MOVE [CORBEG,,CORBEG+1]
	BLT COREND
	MOVE P,[PDL(-PDLLEN)]
	MOVEI [DEBREAK ? EXIT]
	MOVEM JOBAPR
	CLKINT 5.*60.*60.	; must die if around too long
	OUTSTR [ASCIZ/SUNSER started
/]
	MOVEI SVRSKT		; listen for connection
	MOVEM LSNSKT
	PUSHJ P,LISTEN
	MOVEI [	SETOM GOTINT	; flag an interrupt
		MOVE X,JOBCNI
		TLNE X,(INTINR)
		 OUTSTR [ASCIZ/*INR*
/]
		TLNE X,(INTINS)	; INS int
		 OUTSTR [ASCIZ/*INS*
/]
		MOVSI 1,-1	; requeue into TQ from any queue
		DISMIS 1,]
	MOVEM JOBAPR		; set up server location
	CLKINT 60.*15.		; start slow ticking clock
	MOVSI (INTBTS)
	INTENB			; turn on interrupts
	MOVEI TERMID
	MOVEM JOBVER

;falls through
;CPYHST 1DIGTP NOTTIP

; drops in

	OUTSTR [ASCIZ/Connected to /]
	PUSHJ P,MAPHST		; map in host table
	MOVE HOST
	PUSHJ P,HSTNUM		; get HDB
	 TRN			; sorry about errors
	MOVEI A,(1)		; host name
	HRLI A,440700
	SKIPA X,[440700,,TERSTR]
CPYHST:	 IDPB B,X
	ILDB B,A
	JUMPN B,CPYHST
	HLRZ A,1		; pointer to system name
	MOVE B,(A)		; get system name
	MOVE A,FSOCKT		; and ICP socket
	CAMN B,[ASCII/TIP/]	; on a TIP?
	 TRNE A,177774		; just paranoia; make sure a TIP port
	  JRST NOTTIP
	MOVEI B,"#
	IDPB B,X
	LSH A,-16.
	IDIVI A,8.		; ports are octal
	JUMPE A,1DIGTP
	ADDI A,"0 ? IDPB A,X
1DIGTP:	ADDI B,"0 ? IDPB B,X
NOTTIP:	PUSHJ P,SETANM		; set our alias name
	PUSHJ P,UNMHST		; map out the host table
	OUTSTR TERSTR
	OUTSTR [ASCIZ/
/]

; Initialize the Pup channel

	INIT PUP,
	 SIXBIT/PUP/
	 PUPOBH,,PUPIBH
	  JRST [MOVEI X,[ASCIZ/The gateway is down
/]
		PUSHJ P,SNDMSG
		JRST SUICID]

	MOVEI X,[ASCIZ/SU-AI ARPANET => SUnet Gateway Version 1.0
/]
	PUSHJ P,SNDMSG
;GETHSN BADHST GETSKT GETSKN BADSKT

; Get host number

	SETZB A,B		; clear host number register
	MOVEI C,CHTSKT		; initialize socket number
GETHSN:	PUSHJ P,NETICW		; get a digit
	CAIN ".			; socket delimiter?
	 JRST GETSKT
	CAIN ↑M			; return is alternate terminator
	 PUSHJ P,NETICW
	JUMPE PUPICP		; allow null and LF for convenience
	CAIE ↑J
	 CAIN <" >		; terminator?
	  JRST PUPICP		; yes, try to open connection
	CAIL "0			; numeric?
	 CAILE "7
	  JRST BADHST
	LSH A,3			; add new number in
	SUBI "0
	ADD A,
	CAIG A,177777		; host number is losing if greater than this
	 JRST GETHSN
BADHST:	MOVEI X,[ASCIZ/-Invalid host number
/]
	PUSHJ P,SNDMSG
	JRST SUICID

GETSKT:	SETZ C,			; don't use default any more
GETSKN:	PUSHJ P,NETICW		; get a socket digit
	CAIN ↑M			; return is alternate terminator
	 PUSHJ P,NETICW
	JUMPE PUPICP		; allow null and LF for convenience
	CAIE ↑J
	 CAIN <" >		; terminator?
	  JRST PUPICP		; yes, try to open connection
	CAIL "0			; numeric?
	 CAILE "7
	  JRST BADSKT
	LSH C,3			; add new number in
	SUBI "0
	ADD C,
	CAIG C,777		; socket number is losing if greater than this
	 JRST GETSKN
BADSKT:	MOVEI X,[ASCIZ/-Invalid socket number
/]
	PUSHJ P,SNDMSG
	JRST SUICID
;PUPICP

PUPICP:	MOVEM A,SUNHST		; set host number
	MOVEM C,SUNSKT		; set socket number
	MOVEI 8.		; change byte size in buffer header
	DPB [300600,,PUPIBH+1]
	DPB [300600,,PUPOBH+1]
	INBUF PUP,
	OUTBUF PUP,
	MTAPE PUP,RFCBLK	; open up the conection
	MOVE RFCBLK+1		; check for MTAPE error
	STATO PUP,467600
	TRNE 77
	 JRST [	MOVEI X,[ASCIZ/-Host dead
/]
		PUSHJ P,SNDMSG
		JRST SUICID]
	MOVEI X,[ASCIZ/+/]
	PUSHJ P,SNDMSG

; Send ARPANET protocol commands

	TELCMD [IAC WILL ECHO IAC WILL SUPRGA]
	SETOM ECHOP ? SETOM SUPGAP
	LOCK			; lock us in core

; Main program loop

LOOP:	SKIPN GOTINT		; got an interrupt?
	 IMSTW [INTBTS]		; wait for one to happen
	INTMSK [0]		; mask off interrupts
	SETZM GOTINT
	MOVEI 2			; check connection status
	MTAPE NET,
	TLNN 1,(CLSS\CLSR)	; send side gronked?
	 TLNE 2,(CLSS\CLSR)	; receive side?
	  JRST SUICID
;	JRST NETSER
;NETSER NETSR1

; ARPANET server

NETSER:	PUSHJ P,NETICH		; get character from ARPANET
	 JRST PUPSER		; ARPANET input buffer empty
	AOSG NETCMP		; IAC in progress?
	 JRST IACSER
	IRPS OPT,,WILL WONT DO DONT
	 AOSG OPT!P
	  JRST OPT!SR
	TERMIN
	CAIN IAC		; network command?
	 JRST [	SETOM NETCMP	; remember that one is coming
		JRST NETSER]
NETSR1:	SKIPE RCBINP
	 JRST NETSR2
	AOSN FLSCHP		; flush this character?
	 JRST NETSER
	CAIN ↑M			; CR?
	 SETOM FLSCHP		; yes, flush next character
NETSR2:	SOSG PUPOBH+2		; space in buffer?
	 OUTPUT PUP,		; no, output the byte
	IDPB PUPOBH+1		; stuff the character in the buffer
	JRST NETSER		; try for more user characters
;PUPSER PUPSR1 PUPSR2 PUPSR3

; Pup server

PUPSER:	MOVE A,PUPOBH+2		; set fill bits and force the buffer out
	ANDI A,3
	MOVE A,[0
		1
		3
		7](A)
	SKIPLE PUPOBH		; set fill bits only if buffers are setup properly
	DPB A,[	000420,,PUPOBH+1]
;		POINT 4,@PUPOBH+1,35	; Sigh... This can't be in a literal???
	OUTPUT PUP,
PUPSR1:	SOSLE PUPIBH+2		; data available?
	 JRST PUPSR4
	HRRZ 1,PUPIBH
	HRRZ 1,(1)
	SKIPGE (1)		; anything in further buffers?
	 JRST PUPSR2
	MTAPE PUP,INPBLK	; no - new packet available?
	 JRST [	PUSHJ P,NETSND	; send the buffer out
		STATZ PUP,IODEND
		 JRST SUICID
		JRST LOOP]
PUPSR2:	IN PUP,			; yes - get it
	 JRST PUPSR3
	GETSTS PUP,1
	TRNE 1,IODEND\IODTER\IODERR\TMO	; End or error seen?
	 JRST SUICID
	TRZN 1,IOBKTL		; Mark seen?
	 JRST 4,.-1
	SETSTS PUP,(1)		; yes, clear error status
	MTAPE PUP,RMRBLK
	 TRN
	MOVE RMRBLK+2		; get Mark type
	CAIE 5			; Timing Mark?
	 JRST PUPSR1		; something random
	MTAPE PUP,SMRBLK	; yes, send Timing Mark Reply
	 JRST SUICID
	JRST PUPSR1

PUPSR3:	MOVE A,PUPIBH		; get buffer header
	ADD A,1(A)		; find last word in buffer
	MOVE A,1(A)		; get that word
	ANDI A,7		; look at low order bits (faster than LDB)
	TRNE A,4
	  SKIPA A,[4]		; 7 means 4-1 unused bytes
	TRNE A,2		; 3 means 3-1 unused bytes
	  SUBI A,1
	MOVN A,A
	ADDM A,PUPIBH+2		; update count to account for fill bytes
PUPSR4:	ILDB PUPIBH+1		; get the byte
	PUSHJ P,NETOCH		; send it to the network
	JRST PUPSR1
;IACSER PRSTAB WHOLIN

; IAC server

IACSER:	OUTSTR [ASCIZ/*IAC /]
	CAIGE TPLMIN		; big enough?
	 JRST [	PUSHJ P,RNDMSG	; unknown, flush
		JRST NETSER]
	MOVE 1,
	OUTSTR @TPLTAB-TPLMIN(1)
	CAIE IAC
	 CAIGE WILL
	  OUTSTR [ASCIZ/*
/]
	XCT PRSTAB-TPLMIN(1)
	JRST NETSER

DEFINE NC CODE,SERVER
 IFN .+TPLMIN-PRSTAB-CODE,.ERR Lossage at CODE
 SERVER
TERMIN

PRSTAB:				; Protocol command server table

NC SE,[JRST NETSER]
NC NOP,[JRST NETSER]
NC DM,[JRST NETSER]
NC BRK,[JRST NETSER]
NC IP,[JRST NETSER]
NC AO,[JRST NETSER]
NC AYT,[JRST WHOLIN]
NC EC,[JRST NETSER]
NC EL,[JRST NETSER]
NC GA,[JRST NETSER]
NC SB,[JRST NETSER]
NC WILL,[SETOM WILLP]
NC WONT,[SETOM WONTP]
NC DO,[SETOM DOP]
NC DONT,[SETOM DONTP]
NC IAC,[JRST NETSR1]

; IAC AYT

WHOLIN:	MOVEI X,[ASCIZ/SU-AI ARPANET => SU-NET Gateway is alive
/]
	PUSHJ P,SNDMSG
	JRST NETSER
;DOSR DONTSR

; IAC DO/DONT

DOSR:	PUSHJ P,OPTMSG
	CAIN TRNBIN		; binary from host
	 JRST [	SKIPE TRBINP	; catch protocol loops
		 JRST NETSER
		SETOM TRBINP
		TELCMD [IAC WILL TRNBIN]
		JRST NETSER]
	CAIN ECHO		; remote echo (what a win!)
	 JRST [	SKIPE ECHOP	; catch protocol loops
		 JRST NETSER
		SETOM ECHOP
		TELCMD [IAC WILL ECHO]
		JRST NETSER]	; command, we always accept it
	CAIN SUPRGA		; suppress GA?
	 JRST [	SKIPE SUPGAP	; command or reply?
		 JRST NETSER
		SETOM SUPGAP
		TELCMD [IAC WILL SUPRGA]
		JRST NETSER]

; Not an option we like, refuse it

	PUSH P,
	OUTSTR [ASCIZ/⊗IAC WONT/]
	MOVEI IAC
	PUSHJ P,NETOCH
	MOVEI WONT
	PUSHJ P,NETOCH
	POP P,
	PUSHJ P,OPTMSG
	PUSHJ P,NETOCH
	PUSHJ P,NETSND
	JRST NETSER

DONTSR:	PUSHJ P,OPTMSG
	CAIN TRNBIN
	 JRST [	SKIPN TRBINP
		 JRST NETSER
		SETZM TRBINP
		TELCMD [IAC WONT TRNBIN]
		JRST NETSER]
	CAIN ECHO
	 JRST [	SKIPN ECHOP
		 JRST NETSER
		SETZM ECHOP	; back to lossage
		TELCMD [IAC WONT ECHO]
		JRST NETSER]
	CAIN SUPRGA
	 SKIPL SUPGAP
	  JRST NETSER		; protocol violator
	SETZM SUPGAP
	TELCMD [IAC WONT SUPRGA]
	JRST NETSER		; loser
;WILLSR WONTSR

; IAC WILL/WONT

WILLSR:	PUSHJ P,OPTMSG
	CAIN TRNBIN		; binary to host
	 JRST [	SKIPE RCBINP	; catch protocol loops
		 JRST NETSER
		SETOM RCBINP
		TELCMD [IAC DO TRNBIN]
		JRST NETSER]

; Not an option we like, refuse it

	PUSH P,
	OUTSTR [ASCIZ/⊗IAC DONT/]
	MOVEI IAC
	PUSHJ P,NETOCH
	MOVEI DONT
	PUSHJ P,NETOCH
	POP P,
	PUSHJ P,OPTMSG
	PUSHJ P,NETOCH
	PUSHJ P,NETSND
	JRST NETSER


WONTSR:	PUSHJ P,OPTMSG
	CAIN TRNBIN
	 SKIPN RCBINP
	  JRST NETSER
	SETZM RCBINP
	TELCMD [IAC DONT TRNBIN]
	JRST NETSER
;OPTMSG RNDMSG SNDMSG MSGLUP SUICID DEATH ...LIT SVRRTS ERRTNS ERRHAN ERRINS HSTTAB HSTSIX

; Subroutines

; WILL/WONT/DO/DONT option message

OPTMSG:	CAIN EXOPL
	 JRST [	OUTSTR [ASCIZ/ EXOPL*
/]
		POPJ P,]
	OUTCHR [" ]
	CAILE WDOMAX
	 JRST RNDMSG
	MOVE 1,
	OUTSTR @WDOTAB(1)
	OUTSTR [ASCIZ/*
/]
	POPJ P,

RNDMSG:	IDIVI 100	; output the octal for an unknown message
	ADDI "0
	OUTCHR
	IDIVI 10
	ADDI 1,"0
	OUTCHR 1
	ADDI 2,"0
	OUTCHR 2
	OUTSTR [ASCIZ/*
/]
	POPJ P,

; Send a message, b.p. in X

SNDMSG:	TLOA X,440700		; set up b.p.
MSGLUP:	 PUSHJ P,NETOCH
	ILDB X
	JUMPN MSGLUP		; continue until a null hit
	JRST NETSND

; Here to suicide on network errors or idle timeout

SUICID:	PUSHJ P,CLOSER
DEATH:	RESET
	EXIT

...LIT:	CONSTANTS

; Wonderful network routines

SVRRTS==-1			; include server routines
ERRTNS==-1			; include error routines
ERRHAN==-1			; include automagic error handling
ERRINS==<JRST DEATH>		; error instruction
HSTTAB==-1			; include host table magic
HSTSIX==-1			; and alias name kludge

.INSRT NETWRK

END SUNSER