// DLSDialInServer.bcpl -- Control program for Alto DLS

// Last modified July 11, 1983  12:02 PM by Taft
// Last modified January 15, 1985  10:56 AM by Diebert

get "DLSDriver.decl"
get "Pup.decl"
get "DLSControl.decl"
get "AltoDefs.d"

external
[
// outgoing procedures
DLSCommand; Connect; OpenPortForCtx; TalkToRemote; TerminalToNet; NetToTerminal
NetError; Disconnect; CheckConnection; MakeBSP

// Procedures defined in other parts of the DLS control program
DLSCommandError; OtherPupProc; SendTelnetProtocol
LeaveRemoteMode; DLSReturnFrom; DLSRemoteError; Grapevine

// Procedures defined in DLSUtil
GetString; Echo; Confirm; Error; Ws; Wss; Wns; TimeCallStop; Set7BitProcs
GetNumber; WizardMode; OnListCheck

// Procedures defined in DLS driver
DLSResetOutput; DLSOutputEmpty; DLSInputIdle; ControlOut; ControlIn;
DetermineDLSLineSpeed; UpdateCarrierOn; WaitForBitTimes
DLSInput; DLSInput7; DLSOutput; DLSOutput7; DLSOutputTI

// Procedures defined in other packages
OpenLevel1Socket; CloseLevel1Socket; ReleasePBI; OpenRTPSocket; CloseRTPSocket;
CreateBSPStream; CloseBSPSocket; BSPForceOutput; GetPBI;AppendStringToPup;
BSPGetMark; BSPPutMark; BSPPutInterrupt; GetPartner; ExchangePorts; CompletePup
InitializeContext; CallContextList; Block; Enqueue; Dequeue; Unqueue;
SetTimer; TimerHasExpired; Dismiss; PutTemplate; PutNum; WriteRingBuffer

// Procedures defined in operating system
Gets; Puts; Endofs; Resets; Allocate; Free; AddToZone; Zero;
CallSwat; MyFrame; GotoFrame; ReturnFrom; Noop; DefaultArgs; MoveBlock

// incoming statics
mainCtx; ctxTable; versionText; crlf; dlsWizardList
dlsName
@lbTable	// DLS line block table
CtxRunning; sysZone; lenPBI; pbiFreeQ; ndbQ; keyDsp; postedNotice; socketSequence
loginServerCB;
]

// ---------------------------------------------------------------------------
let DLSCommand(ctx) be
// ---------------------------------------------------------------------------
// Does local command decoding.  Returns when user hangs up.
[
let type = nil
let length = nil
let width = nil
let dlb = ctx>>CTX.dlb
let soc = lv ctx>>CTX.socket
dlb>>DLB.error = DLSCommandError
ctx>>CTX.lineState = lineStateActive  // Flag not in remote mode
dlb>>DLB.timeout = 100  // 1-second timeout for DLS Gets
Puts(dlb, $>)  // Prompt

// Dispatch on command character
let char = Gets(dlb)
switchon char into
   [
   case $8:
      Wss(dlb, "Set line to 8 bit no parity ")
      if Confirm(dlb) then [ dlb>>DLB.eightBit = 1; dlb>>DLB.flowControl = 0 ]
      endcase

   case $7:
      Wss(dlb, "Set line to 7 bit even parity ")
      if Confirm(dlb) then [ dlb>>DLB.eightBit = 0; dlb>>DLB.flowControl = 1 ]
      endcase

   case 3:  // Control-C means connect to default host
      if Connect(ctx, ctx>>CTX.host) then TalkToRemote(ctx)
      endcase

   case $B: case $b:
      Wss(dlb, "Bye [Confirm] ")
      if Confirm(dlb) then
         [
         Disconnect(ctx)
         PutTemplate(dlb, "#$O off*n*l", dlb>>DLB.line)
         return
         ]
      endcase

   case $C: case $c:
      if Connect(ctx, 0) then TalkToRemote(ctx)
      endcase

   case $D: case $d:
      Wss(dlb, "Disconnect ")
      if Confirm(dlb) then Disconnect(ctx, 3000)
      endcase

   case $E: case $e:
      Wss(dlb, "Escape character currently = ")
      Echo(dlb, ctx>>CTX.escapeChar)
      Wss(dlb, " Change to ")
      char = Gets(dlb)
      if char eq $*n % char eq $*l % char eq 177B then
         [
         Error(dlb, " Illegal escape character*n*l")  // Don't allow cr, lf, delete
         endcase
         ]
      Echo(dlb, char); Puts(dlb, $*s)
      if Confirm(dlb) then ctx>>CTX.escapeChar = char
      endcase

   case $F: case $f:
      Wss(dlb, "Flush typein stream ")
      unless ctx>>CTX.socketOpen do
         [ Error(dlb, "? No connection open*n*l"); endcase ]
      if Confirm(dlb) then
         if BSPPutInterrupt(soc, 0, "Sync") then BSPPutMark(soc, 1)
      endcase

   case $G: case $g:
      Wss(dlb, "Grapevine...")
      if Grapevine(ctx) then TalkToRemote(ctx)
      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:
      PutTemplate(dlb, "Local echoing $S ", (ctx>>CTX.localEcho? "off", "on"))
      if Confirm(dlb) then ctx>>CTX.localEcho = not ctx>>CTX.localEcho
      endcase

   case $P: case $p:
      PutTemplate(dlb, "Pad $S ", (dlb>>DLB.noPad? "on", "off"))
      if Confirm(dlb) then [ dlb>>DLB.noPad = not dlb>>DLB.noPad; Set7BitProcs(dlb) ]
      endcase

   case $R: case $r:
      Wss(dlb, "Resume connection ")
      unless ctx>>CTX.socketOpen do
         [ Error(dlb, "? No connection open*n*l"); endcase ]
      if Confirm(dlb) then TalkToRemote(ctx)
      endcase

   case $T: case $t:
      Wss(dlb, "Set terminal parameters*n*lType? ")
      type = GetNumber(dlb)
      if type ls 0 then endcase
      if type gr 10 % (type gr 3 & type ls 7) do
         [ Wss(dlb, "Bad terminal type*n*l"); endcase ]
      ctx>>CTX.terminalType = type
      Wss(dlb, "Width? ")
      width = GetNumber(dlb)
      if width ls 0 then endcase
      ctx>>CTX.terminalWidth = width
      Wss(dlb, "Length? ")
      length = GetNumber(dlb)
      if length ls 0 then endcase
      ctx>>CTX.terminalLength = length
      endcase

   case $V: case $v:
      PutTemplate(dlb, "Version: $S running on Alto $O#$O#*n*l",
       versionText, (ndbQ!0)>>NDB.localNet, (ndbQ!0)>>NDB.localHost)
      endcase

   case $W: case $w:
      if ctx>>CTX.name eq 0 do
         [
         Wss(dlb, "Wizard mode*n*lLogin required. *n*l")
         endcase
         ]
      if dlb>>DLB.lineType ne ltHardwired do
         unless dlb>>DLB.carrierOff then
            [
            Wss(dlb, "Wizard mode*n*lYou must break connection first!!!*n*l")
            endcase
            ]
      Wss(dlb, "Wizard mode [Confirm] ")
      if Confirm(dlb) then
         if OnListCheck(ctx, dlb, dlsWizardList) then
            WizardMode(ctx, dlb)
      endcase

   case $X: case $x:
      PutTemplate(dlb, "Xon/Xoff (Flow Control) $S ", (dlb>>DLB.flowControl? "off", "on"))
      if Confirm(dlb) then dlb>>DLB.flowControl = not dlb>>DLB.flowControl
      endcase
 
   case $?:
      Wss(dlb, "? Commands are: Bye, Connect, Disconnect, Escape, Flush, Grapevine*n*l")
      Wss(dlb, " Ignore escape char, Local, Pad, Resume, Terminal, Version,*n*l")
      Wss(dlb, " Xon/Xoff, 7 bit, 8 bit.*n*l")
      if ctx>>CTX.host ne 0 then
         PutTemplate(dlb, " Control-C = connect to $S*n*l", ctx>>CTX.host)
      endcase

   case 177B: // delete
      Wss(dlb, " XXX")

   case $*n: case $*l: case $*s:
      Wss(dlb, crlf)
      endcase

   default:
      Error(dlb, " ?*n*l", char)
   ]
] repeat

// ---------------------------------------------------------------------------
and Connect(ctx, hostName)  =  valof
// ---------------------------------------------------------------------------
[
let dlb = ctx>>CTX.dlb
Wss(dlb, "Connect to: ")
if ctx>>CTX.socketOpen then
   [ Error(dlb, "? Connection already open*n*l"); resultis false ]
let frnPort = vec lenPort
let string = vec 20
test hostName eq 0
   ifso
      [
      unless GetString(dlb, string, 40) resultis false
      hostName = string
      ]
   ifnot
      PutTemplate(dlb, "$S*n*l", hostName)
unless GetPartner(hostName, dlb, frnPort, 0, 1) do
   [ Error(dlb, crlf); resultis false ]
if frnPort>>Port.host eq 0 then
   [
   Error(dlb, "Inadequate foreign port specification*n*l")
   resultis false
   ]
resultis MakeBSP(frnPort, ctx)
]


// ---------------------------------------------------------------------------
and Disconnect(ctx, timeout) be
// ---------------------------------------------------------------------------
[
let dlb = ctx>>CTX.dlb
Set7BitProcs(dlb)
if ctx>>CTX.socketOpen then
   [
   if ctx>>CTX.auxCtx ne 0 then
      [
      Unqueue(mainCtx, ctx>>CTX.auxCtx)
      ctx>>CTX.auxCtx = 0
      ]
   CloseBSPSocket(lv ctx>>CTX.socket, timeout)
   ctx>>CTX.socketOpen = false
   ]
]

// ---------------------------------------------------------------------------
and CheckConnection(ctx) = valof
// ---------------------------------------------------------------------------
// Returns true if the connection was open and became closed.
[
if ctx>>CTX.socketOpen then
   test ctx>>CTX.socket.state eq stateOpen
      ifso if ctx>>CTX.timeout then
         [
         Disconnect(ctx, 0)  // Abort connection
         Wss(ctx>>CTX.dlb, " [Connection timed out]*n*l>")
         resultis true
         ]
      ifnot
         [
         Disconnect(ctx, 3000)
         Wss(ctx>>CTX.dlb, " [Connection closed remotely]*n*l>")
         resultis true
         ]
resultis false
]

// ---------------------------------------------------------------------------
and OpenPortForCtx(ctx, frnPort) = valof
// ---------------------------------------------------------------------------
[
let lclPort = vec lenPort; Zero(lclPort, lenPort)
if socketSequence eq 0 % socketSequence eq socTransient then
   socketSequence = socketSequence+1
lclPort>>Port.socket^1 = socketSequence
lclPort>>Port.socket^2 = ctx>>CTX.dlb>>DLB.line
socketSequence = socketSequence+1
let soc = lv ctx>>CTX.socket
Zero(soc, lenBSPSoc)
OpenLevel1Socket(soc, lclPort, frnPort)
resultis soc
]

// ---------------------------------------------------------------------------
and TalkToRemote(ctx) be
// ---------------------------------------------------------------------------
[
let dlb = ctx>>CTX.dlb
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, NetToTerminal, 1))
auxCtx!3 = ctx
ctx>>CTX.auxCtx = auxCtx
ctx>>CTX.lineState = lineStateRemote  // Flag that we are in remote mode
ctx>>CTX.timeout = false
ctx>>CTX.returnFrame = MyFrame()  // Frame to force return to
dlb>>DLB.error = DLSRemoteError
dlb>>DLB.timeout = -1  // Never time out DLS Gets
TerminalToNet(ctx)  // Returns on escape char or error
Unqueue(mainCtx, auxCtx)
ctx>>CTX.auxCtx = 0
dlb>>DLB.error = DLSCommandError
Wss(dlb, crlf)
Set7BitProcs(dlb)
]

// ---------------------------------------------------------------------------
and TerminalToNet(ctx) be
// ---------------------------------------------------------------------------
// This is a procedure called within the line's main context.
// Its task is to copy characters from terminal to net.
// It returns if either the escape character is typed or the
// connection is broken.  The NetToTerminal process can force us
// to return by subterfuge involving diddling of stack frames.
[
let dlb = ctx>>CTX.dlb
let soc = lv ctx>>CTX.socket
let bspStr = lv soc>>BSPSoc.bspStr

// Send terminal parameters.
let type, length = ctx>>CTX.terminalType, ctx>>CTX.terminalLength
if type eq 0 & dlb>>DLB.baud ge 1200 do
   [
   type = 10
   if ctx>>CTX.terminalLength eq 0 then length = 24
   ]
if type ne 0 then SendTelnetProtocol(soc, 4B, type)
if length ne 0 then SendTelnetProtocol(soc, 3B, length)
let width = ctx>>CTX.terminalWidth
if width eq 0 then width = selecton dlb>>DLB.baud into
   [  // Select width by assuming terminal type on the basis of baud rate
   case 300: 79  // TI 700
   case 1200: 80  // Tektronix 4023
   default: 72  // All others (including Teletype)
   ]
SendTelnetProtocol(soc, 2B, width)

// Main loop to send terminal characters to net.
// This code accumulates characters and sends them only when the line goes
// idle or one second elapses from the beginning of a burst, whichever
// occurs first.  This attempts to maximize the number of characters per Pup
// during sustained activity without introducing excessive echoing delays.
   [ // repeat
   let burstStarted = false
   let timer = nil

      [ // repeat
      let char = Gets(dlb)
      unless burstStarted do
         [ burstStarted = true; SetTimer(lv timer, 100) ]
      test ctx>>CTX.escapeDisabled
         ifso [
            test TimerHasExpired(lv ctx>>CTX.escapeCharTimer)
               ifso test ctx>>CTX.escapeTime le 0
                  ifso [ ctx>>CTX.escapeDisabled = 0 ]
                  ifnot [ ctx>>CTX.escapeTime = ctx>>CTX.escapeTime - 1;
                     SetTimer(lv ctx>>CTX.escapeCharTimer, 100)  ]
               ifnot [ ]
            ]
         ifnot [ if (char & 177b) eq ctx>>CTX.escapeChar do
               [ Set7BitProcs(dlb)
               return ]
            ]
      Puts(bspStr, char)
      if ctx>>CTX.localEcho then
         [
         Puts(dlb, char)
         if char eq $*n then [ Puts(bspStr, $*l); Puts(dlb, $*l) ]
         ]
      if Endofs(dlb) then
         [
         if TimerHasExpired(lv timer) then break
         WaitForBitTimes(dlb, 2)  // wait for next char to start if it's going to
         if DLSInputIdle(dlb) then break
         ]
      ] repeat

   // sendNow if forcing due to timeout -- because the next ForceOut
   // is also likely to be invoked by a timeout, and one second is more
   // than the Pup package's timeout before requesting acknowledgment.
   BSPForceOutput(soc, TimerHasExpired(lv timer))
   ] repeat
]

// ---------------------------------------------------------------------------
and NetToTerminal(ctx) be
// ---------------------------------------------------------------------------
// This is a separate process whose only task is to copy characters
// from net to terminal.
[
ctx = ctx!3  // Get main context for this line
let dlb = ctx>>CTX.dlb
let str = lv ctx>>CTX.socket.bspStr
   [
   let char = Gets(str)
   test ctx>>CTX.syncCount eq 0
      ifso Puts(dlb, char)
      ifnot DLSResetOutput(dlb)
   ] repeat
]

// ---------------------------------------------------------------------------
and NetError(str, ec) = valof
// ---------------------------------------------------------------------------
// This is the procedure called via the BSP stream error dispatch
// for any abnormal condition.  Note that failures may occur either
// within the line's main context (TerminalToNet) or within
// the auxiliary context (NetToTerminal).
[
let soc = str-offset BSPSoc.bspStr/16
let ctx = soc-offset CTX.socket/16
let dlb = ctx>>CTX.dlb
switchon ec into
   [
   case ecMarkEncountered:
      switchon BSPGetMark(soc) into
         [
         case 1:  // Data Mark
            ctx>>CTX.syncCount = ctx>>CTX.syncCount-1
            DLSResetOutput(dlb)
            while ctx>>CTX.syncCount ls 0 do Block()
            endcase
         case 5:  // Timing Mark
            until DLSOutputEmpty(dlb) do Block()
            until BSPPutMark(soc, 6) loop  // Timing Mark Reply
         ]  // Unknown Mark types are ignored
      resultis 0  // Return a null -- the user will never notice!

   case ecPutsTimeout:
      if soc>>BSPSoc.unAckedPups eq 0 & soc>>BSPSoc.bytesPerPup ne 0 then
         [
         if ctx eq CtxRunning then  //do this only in main ctx
            Error(dlb, "*007")  //too much typeahead, Warren
         resultis false
         ]
      ctx>>CTX.timeout = true  //fall thru to other error cases

   case ecBadStateForGets:
   case ecBadStateForPuts:
      LeaveRemoteMode(ctx)
   ]
]


// ---------------------------------------------------------------------------
and MakeBSP(frnPort, ctx) = valof
// ---------------------------------------------------------------------------
[
let dlb = ctx>>CTX.dlb
let soc = OpenPortForCtx(ctx, frnPort)
let login = CheckForLogin(frnPort, ctx>>CTX.name)
OpenRTPSocket(soc, 0, modeInitAndReturn, 0, OtherPupProc)
let timer = nil
SetTimer(lv timer, 3000)  // 30 seconds
   [
   Block()
   if soc>>RTPSoc.state eq stateOpen break
   if soc>>RTPSoc.state ne stateRFCOut % TimerHasExpired(lv timer) %
    dlb>>DLB.carrierOff then
      [
      CloseRTPSocket(soc, 0)
      CloseLevel1Socket(soc)
      ctx>>CTX.socketOpen = false
      Wss(dlb, "*n*lFailed to connect*n*l")
      resultis false
      ]
   ] repeat
CreateBSPStream(soc)
ctx>>CTX.socketOpen = true
soc>>BSPSoc.error = NetError  // Own stream error procedure
ctx>>CTX.syncCount = 0
if login then
   PutTemplate(lv soc>>BSPSoc.bspStr, "Login $S $S 1*n", ctx>>CTX.name, ctx>>CTX.password)
resultis true
]

// ---------------------------------------------------------------------------
and CheckForLogin(frnPort, name) = valof
// ---------------------------------------------------------------------------
[
let sendLogin = false
let soc = vec lenPupSoc
let infoPort = vec lenPort
MoveBlock(infoPort, frnPort, lenPort)
infoPort>>Port.socket^1 = 0
infoPort>>Port.socket^2 = miscServicesSocket
OpenLevel1Socket(soc, 0, infoPort)
for i=1 to 5 do         //Try five times....
   [SendWherePup
   let p=GetPBI(soc)
   AppendStringToPup(p, 1, name)
   p>>PBI.pup.type = typeWhereUserRequest
   CompletePup(p)

   let wait=nil; SetTimer(lv wait, 200)   // 2 sec
   Block() repeatuntil TimerHasExpired(lv wait) %
      soc>>PupSoc.iQ.head ne 0
   p=Dequeue(lv soc>>PupSoc.iQ)
   if p eq 0 then loop
   let pup=lv p>>PBI.pup
   switchon p>>PBI.pup.type into
   [
   case typeWhereUserReply:
      [
      sendLogin = true
      ReleasePBI(p)
      break
      ]
   default:
      [ ReleasePBI(p) ]
      ]         //Switchon
   ]SendWherePup
CloseLevel1Socket(soc)
resultis sendLogin
]