// DLSDialOutServer.bcpl -- Telnet server providing dial-out capability
// Last modified August 22, 1982 12:33 PM by Taft
// Last modified January 15, 1985 11:22 AM by Diebert
get "DLSDriver.decl"
get "Pup.decl"
get "DLSControl.decl"
external
[
// Outgoing procedures
DLSSocketNotFound; TelnetRendezvousServer; DialOutTop; SendAbort; GetNumber
OtherPupProc;
// Incoming procedures
NetToDialOutLine; DialOutLineToNet; WizardMode; OnListCheck; DialOutCall
HangUp; Echo; Confirm; Error; GetString; LeaveRemoteMode; DialOut; OpenPortForCtx
ControlOut; SetDLSLineSpeed; DLSOutput7; DLSResetInput; DLSResetOutput
DLSInputIdle; WaitForBitTimes;
ExchangePorts; AppendStringToPup; CompletePup; ReleasePBI; PupError
OpenRTPSocket; CreateBSPStream; BSPGetMark; BSPPutMark; BSPForceOutput
InitializeContext; Block; Dismiss
Enqueue; Dequeue; Unqueue; SetTimer; TimerHasExpired; MultEq
Gets; Puts; Endofs; Errors; Wss; PutTemplate
MoveBlock; SetBlock; SysErr; ReturnFrom; MyFrame; DialOutBSPError
DLSInput; DLSInput7; DLSOutput; ControlIn
Login; DialOutDialIn; Free; StatusToLog; CallSwat
GenerateLongSpace; TelnetGets; InnerGets; TelnetEndofs; TelnetResets
TelnetPuts
TimeCallStart; TimeCallStop; Set7BitProcs
// Outgoing statics
strayPupQ
// Incoming statics
dlsName; dlsRegistry; dlsOutList; dlsWizardList
@lbTable; ctxTable; mainCtx; CtxRunning; postedNotice; crlf; ndbQ; sysZone
logstream;
]
static
[
strayPupQ
]
manifest
[
// Telnet mark types
markSync = 1
markLineWidth = 2
markPageLength = 3
markTerminalType = 4
markTiming = 5
markTimingReply = 6
]
structure AuxCtx: // Auxiliary (DialOutLineToNet) context
[
blank word 3 // usual Ctx stuff
mainCtx word // -> main context for line
active word // true if recent activity in net -> line direction
]
// ---------------------------------------------------------------------------
let DLSSocketNotFound(pbi) be Enqueue(strayPupQ, pbi)
// ---------------------------------------------------------------------------
// Called from Pup level 1 with packet for unknown local socket.
// ---------------------------------------------------------------------------
and TelnetRendezvousServer() be
// ---------------------------------------------------------------------------
// Context that catches stray Pups (ones not for any existing socket)
// and creates a Telnet server when an RFC arrives.
// The following "rendezvous sockets" are defined:
// 1 Hunt for any 300-baud dial-out line
// 212 Hunt for any Bell 212 dial-out line
// 300 Hunt for any Bell 103 dial-out line
// 1200 Hunt for any Vadic 3400 dial-out line
// 100000+n Connect to line n, if it exists and is a DLS data line
[
Dismiss(1)
while strayPupQ!0 ne 0 do HandleRSPup(Dequeue(strayPupQ))
] repeat
// ---------------------------------------------------------------------------
and HandleRSPup(pbi) be
// ---------------------------------------------------------------------------
[
let modemWanted, line = -1, nil
// Check for Whereuser
if pbi>>PBI.pup.type eq typeWhereUserRequest & pbi>>PBI.pup.dPort.host ne 0 do
[
ExchangePorts(pbi)
CompletePup(pbi, typeWhereUserReply, pupOvBytes)
return
]
// Require it to be an RFC and not broadcast.
if pbi>>PBI.pup.type eq typeRFC & pbi>>PBI.pup.dPort.host ne 0 &
pbi>>PBI.pup.dPort.socket↑1 eq 0 then
switchon pbi>>PBI.pup.dPort.socket↑2 into
[
case 1: case 300b:
modemWanted = ltBell103; endcase
case 212b:
modemWanted = ltBell212; endcase
case 1200b:
modemWanted = ltVadic3400; endcase
default:
line = pbi>>PBI.pup.dPort.socket↑2 - 100000b
if line uls numLines &
(lbTable!line)>>LBH.lineType ge ltData then modemWanted = ltIllegal
]
if modemWanted eq -1 then [ PupError(pbi, 2, "No such port"); return ]
// Default net field of foreign connection port
let connPort = lv pbi>>PBI.pup.words
if connPort>>Port.net eq 0 then
connPort>>Port.net = pbi>>PBI.pup.sPort.net
let ctx = 0
test modemWanted eq ltIllegal
ifso
[ // Asking for specific line
if TestDuplicate(pbi, line) then return // Duplicate RFC
ctx = ctxTable!line
unless ctx>>CTX.lineState le lineStateOn do
[ SendAbort(pbi, "Line is busy"); return ]
]
ifnot
[ // Asking for any line of specific type
// Check for duplicate RFC by searching for a connection with the same
// foreign port and connection ID. Also search for a dial-out line that
// is not presently in use and that has the correct type of modem.
for testLine = 0 to numLines-1 do
[
if TestDuplicate(pbi, testLine) then return // Duplicate RFC
let dlb = lbTable!testLine
if dlb>>DLB.lineType eq ltDataSet & dlb>>DLB.dclm ne 0 &
(ctxTable!testLine)>>CTX.lineState eq lineStateOff do
[
if modemWanted eq dlb>>DLB.modemType do
[ line = testLine; ctx = ctxTable!line ] // free correct type
]
]
// Reject the request if did not find a free dial-out line
if ctx eq 0 then
[ SendAbort(pbi, "No dial-out lines available"); return ]
]
// HandleRSPup (cont'd)
// Open the BSP connection
let soc = OpenPortForCtx(ctx, connPort)
OpenRTPSocket(soc, 0, modeImmediateOpen, lv pbi>>PBI.pup.id)
CreateBSPStream(soc)
ctx>>CTX.socketOpen = true
// Tell the context to be a dial-out server
ctx>>CTX.lineState = lineStateDialOut
if modemWanted ne ltIllegal then SetDLSLineSpeed(ctx>>CTX.dlb,
selecton modemWanted into [
case ltBell103: 300
case ltBell212:
case ltVadic3400: 1200 ])
// Send answering RFC
SendRFC(pbi, lv ctx>>CTX.socket)
]
// ---------------------------------------------------------------------------
and TestDuplicate(pbi, line) = valof
// ---------------------------------------------------------------------------
[
let ctx = ctxTable!line
let dlb = lbTable!line
if dlb>>LBH.lineType ge ltData & ctx>>CTX.socketOpen &
MultEq(lv ctx>>CTX.socket.frnPort, lv pbi>>PBI.pup.words, lenPort) &
MultEq(lv ctx>>CTX.socket.connID, lv pbi>>PBI.pup.id) then
[ SendRFC(pbi, lv ctx>>CTX.socket); resultis true ] // Duplicate RFC
resultis false
]
// ---------------------------------------------------------------------------
and SendRFC(pbi, soc) be
// ---------------------------------------------------------------------------
[
MoveBlock(lv pbi>>PBI.pup.words, lv soc>>PupSoc.lclPort, lenPort)
ExchangePorts(pbi)
CompletePup(pbi, typeRFC, pupOvBytes+6)
]
// ---------------------------------------------------------------------------
and SendAbort(pbi, string) be
// ---------------------------------------------------------------------------
[
pbi>>PBI.pup.words↑1 = 0
AppendStringToPup(pbi, 3, string)
ExchangePorts(pbi)
CompletePup(pbi, typeAbort)
]
// ---------------------------------------------------------------------------
and DialOutTop(ctx) be
// ---------------------------------------------------------------------------
// DLSTop calls this procedure when the line is being
// controlled from a server Telnet connection.
[
// Manufacture server Telnet stream
let tstr = vec lST
SetBlock(tstr, SysErr, lST)
tstr>>ST.par1 = ctx // -> owning context
tstr>>ST.gets = TelnetGets
tstr>>ST.endof = TelnetEndofs
tstr>>ST.reset = TelnetResets
tstr>>ST.puts = TelnetPuts
ctx>>CTX.socket.error = DialOutBSPError
let dlb = ctx>>CTX.dlb
if dlb>>DLB.carrierOff then
[
// Drop Data Terminal Ready so the modem won't auto-answer
ControlOut(dlb>>DLB.otherLine, false)
dlb>>DLB.puts = DLSOutput7 // No padding!
]
DLSResetInput(dlb)
DLSResetOutput(dlb)
// Give greeting
PutTemplate(tstr, "$S*n*l$S Line #$O, ($D Baud), Escape character = ",
dlsName,
valof [
switchon dlb>>DLB.lineType into
[
case ltHardwired: resultis "Hardwired"
case ltTelenet: resultis "Telenet"
case ltDataSet: resultis selecton dlb>>DLB.modemType into
[
case ltBell103: "Bell 103 Dial Out"
case ltBell212: "Bell 212a Dial Out"
case ltVadic3400: "Vadic 3400 Dial Out"
default: "?"
]
default: resultis "?"
]
], dlb>>DLB.line, dlb>>DLB.baud)
Echo(tstr, ctx>>CTX.escapeChar)
Wss(tstr, crlf)
if postedNotice ne 0 then
PutTemplate(tstr, "*007****** $S*n*l", postedNotice)
// Call server Telnet command interpreter
DialOutCommand(ctx, tstr)
// Return to DLSTop, which will close connection and hang up modem.
// If the Telnet connection breaks, ReturnFrom(DialOutTop) is done.
]
// ---------------------------------------------------------------------------
and DialOutCommand(ctx, tstr) be
// ---------------------------------------------------------------------------
[
let dlb = ctx>>CTX.dlb
Puts(tstr, $>) // Prompt
let char = Gets(tstr)
switchon char into
[
case $8:
Wss(tstr, "Set line to 8 bit no parity ")
if Confirm(tstr) then [ dlb>>DLB.eightBit = 1; dlb>>DLB.flowControl = false ]
endcase
case $7:
Wss(tstr, "Set line to 7 bit even parity ")
if Confirm(tstr) then [ dlb>>DLB.eightBit = 0; dlb>>DLB.flowControl = true ]
endcase
case $B: case $b:
[
Wss(tstr, "Baud rate = ")
if dlb>>DLB.baud eq 1200 & dlb>>DLB.dclm ne 0 then
[ Error(tstr, "1200, cannot be changed*n*l"); endcase ]
let baud = GetNumber(tstr)
if baud ge 0 do
test baud ge 110 & baud le 2400 & (dlb>>DLB.dclm eq 0 % baud le 300)
ifso
[
SetDLSLineSpeed(dlb, baud)
if dlb>>DLB.dclm ne 0 then
dlb>>DLB.puts = DLSOutput7 // No padding!
]
ifnot Error(tstr, "? Illegal baud rate for this line*n*l")
endcase
]
case $C: case $c:
[
test dlb>>DLB.dclm ne 0 & dlb>>DLB.carrierOff
ifso
[
if ctx>>CTX.name eq 0 do
[
Wss(tstr, "Call phone number*n*lLogin required. *n*l")
endcase
]
Wss(tstr, "Call phone number: ")
if DialOutCall(ctx, tstr) then
[ DialOutRemote(ctx, tstr)
Set7BitProcs(dlb)
if dlb>>DLB.carrierOff then
PutTemplate(tstr, "Length of call was $UD min.*n*l", TimeCallStop(ctx))
]
]
ifnot
[ Wss(tstr, "Connect!*n*l"); DialOutRemote(ctx, tstr); Set7BitProcs(dlb) ]
endcase
]
case $D: case $d:
[
Wss(tstr, "Disconnect [Confirm] ")
if Confirm(tstr) then
[ HangUp(dlb, false)
if dlb>>DLB.dclm ne 0 then
PutTemplate(tstr, "Length of call was $UD min.*n*l", TimeCallStop(ctx))
]
endcase
]
case $E: case $e:
[
Wss(tstr, "Escape character currently = ")
Echo(tstr, ctx>>CTX.escapeChar)
Wss(tstr, " Change to ")
char = Gets(tstr)
if char eq $*n % char eq $*l % char eq #177 then
[ Error(tstr, " ?*n*l"); endcase ]
Echo(tstr, char); Puts(tstr, $*s)
if Confirm(tstr) then ctx>>CTX.escapeChar = char
endcase
]
case $I: case $i:
Wss(dlb, "Ignore escape character ")
if Confirm(dlb) then [ Wss(dlb, "Number of seconds to ignore for? ")
ctx>>CTX.escapeTime = GetNumber(dlb)
if ctx>>CTX.escapeTime le 0 then [ ctx>>CTX.escapeTime = 0; endcase ]
ctx>>CTX.escapeDisabled = 1
SetTimer(lv ctx>>CTX.escapeCharTimer, 100) ]
endcase
case $L: case $l:
[
Wss(tstr, "Login ...")
Login(ctx, tstr, dlsOutList, "Dial Out Login")
endcase
]
case $Q: case $q:
[
Wss(tstr, "Quit [Confirm] ")
if Confirm(tstr) then
[ HangUp(dlb, false)
return ]
endcase
]
case $R: case $r:
[
Wss(tstr, "Resume connection ")
if dlb>>DLB.carrierOff then
[ Error(tstr, "*n*lSorry, DLS line is disconnected.*n*l"); endcase ]
if Confirm(tstr) then
[ DialOutRemote(ctx, tstr)
Set7BitProcs(dlb)
if dlb>>DLB.carrierOff then
PutTemplate(tstr, "Length of call was $UD min.*n*l", TimeCallStop(ctx))
]
endcase
]
case $X: case $x:
PutTemplate(tstr, "Xon/Xoff (Flow Control) $S ", (dlb>>DLB.flowControl? "off", "on"))
if Confirm(tstr) then dlb>>DLB.flowControl = not dlb>>DLB.flowControl
endcase
case $W: case $w:
if ctx>>CTX.name eq 0 do
[
Wss(tstr, "Wizard mode*n*lLogin required. *n*l")
endcase
]
if dlb>>DLB.lineType ne ltHardwired do
unless dlb>>DLB.carrierOff then
[
Wss(tstr, "Wizard mode*n*lYou must break connection first!!!*n*l")
endcase
]
Wss(tstr, "Wizard mode [Confirm] ")
if Confirm(tstr) then
if OnListCheck(ctx, tstr, dlsWizardList) then
WizardMode(ctx, tstr)
endcase
case #177: // delete
Wss(tstr, " XXX")
case $*n: case $*l: case $*s:
[ Wss(tstr, crlf); endcase ]
default:
[
PutTemplate(tstr,
"? Commands are: Baud, $S, Disconnect, Escape, Ignore escape char, Login, Quit*n*lResume, Xon/Xoff, 7 bit, 8 bit.*n*l",
(dlb>>DLB.dclm ne 0? "Call", "Connect"))
]
]
] repeat
// ---------------------------------------------------------------------------
and DialOutRemote(ctx, tstr) be
// ---------------------------------------------------------------------------
[
let dlb = ctx>>CTX.dlb
BSPForceOutput(lv ctx>>CTX.socket)
test dlb>>DLB.eightBit eq 1
ifso
[
dlb>>DLB.gets = DLSInput
dlb>>DLB.puts = DLSOutput
]
ifnot Set7BitProcs(dlb)
let auxCtx = vec 150
Enqueue(mainCtx, InitializeContext(auxCtx, 150, DialOutLineToNet, size AuxCtx/16 - 3))
auxCtx>>AuxCtx.mainCtx = ctx
ctx>>CTX.auxCtx = auxCtx
ctx>>CTX.returnFrame = MyFrame()
dlb>>DLB.error = DialOutDLSError
NetToDialOutLine(ctx, tstr)
Unqueue(mainCtx, auxCtx)
ctx>>CTX.auxCtx = 0
Set7BitProcs(dlb)
Wss(tstr, crlf)
if dlb>>DLB.carrierOff then
[
Wss(tstr, "> [Dial-out connection broken]*n*l")
HangUp(dlb, false)
]
]
// ---------------------------------------------------------------------------
and DialOutDLSError(dlb) be LeaveRemoteMode(ctxTable!(dlb>>DLB.line))
// ---------------------------------------------------------------------------
// Called if dial-out connection breaks while we are talking to it.
// ---------------------------------------------------------------------------
and OtherPupProc(pbi) be
// ---------------------------------------------------------------------------
// Procedure called for non-RTP, non-BSP Pups
[
let soc = pbi>>PBI.socket
let ctx = soc-offset CTX.socket/16
let dlb = ctx>>CTX.dlb
let firstByte = nil
switchon pbi>>PBI.pup.type into
[
case typeInterrupt:
ctx>>CTX.syncCount = ctx>>CTX.syncCount+1
endcase
case typeAbort:
Wss(dlb, "*n*l> [Abort] ")
firstByte = 3
docase -1
case typeError:
if soc>>BSPSoc.state eq stateAbort then
[ Wss(dlb, "*n*l> [Error] "); firstByte = 25; docase -1 ]
endcase
case -1:
for i = firstByte to pbi>>PBI.pup.length-pupOvBytes do
Puts(dlb, pbi>>PBI.pup.bytes↑i)
Wss(dlb, crlf)
endcase
]
ReleasePBI(pbi)
]