// 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)
]