// CopyDiskNet.bcpl
// Copyright Xerox Corporation 1979, 1980, 1981
// Last modified November 3, 1981  11:30 PM by Boggs

get "Pup.decl"
get "AltoDefs.d"
get "CopyDisk.decl"
get "CopyDiskNet.decl"

external
[
// outgoing procedures
InitCopyDiskNet; MakeNetSS

// incoming procedures from OS and packages
CreateBSPStream; CloseBSPSocket; OpenRTPSocket; CloseRTPSocket
OpenLevel1Socket; CloseLevel1Socket; GetPBI; ReleasePBI
InitPupLevel1; CompletePup; GetPartner; HLookup
InvertLine; GetLinePos; SetBitPos
Puts; Resets; Closes; PutTemplate
ExtractSubstring; CopyString; CreateStringStream
Block; InitializeContext; Dismiss; SetTimer; TimerHasExpired
TruePredicate; FalsePredicate; ReadCalendar
Allocate; Free; Zero; MoveBlock
Dequeue; Enqueue; Unqueue

// incoming procedures from CopyDisk
NetCompatible; NetPrintDA; NetCompare
NetReader; NetWriter; NetPrintBlock; PrintPort
GetBlock; PutBlock; PutString; PrintDiskParams
MakeSS; DoIt; Wss; GetNamePass

// incoming statics
sysZone; CtxRunning; ctxQ; versionText
debugFlag; writeProtectFlag; defaultTimeout
userName; userPass; connName; connPass
dsp; titleDsp; controlLock; pupRT; ndbQ
]

static [ ourName; otherPupQ ]

//----------------------------------------------------------------------------
let InitCopyDiskNet() be
//----------------------------------------------------------------------------
[
InitPupLevel1(sysZone, ctxQ, 10)
Enqueue(ctxQ, InitializeContext(Allocate(sysZone, 400), 400, NetServer))
Enqueue(ctxQ, InitializeContext(Allocate(sysZone, 250), 250, OtherPupCtx))
otherPupQ = Allocate(sysZone, 2); otherPupQ!0 = 0
]

//----------------------------------------------------------------------------
and NetServer(ctx) be
//----------------------------------------------------------------------------
[
let servSoc = Allocate(sysZone, lenBSPSoc)  //freed by DestoryNetSS
OpenLevel1Socket(servSoc, table [ 0; 0; socketCD ])
   [
   OpenRTPSocket(servSoc, ctxQ, modeListenAndReturn, 0, OtherPup)
   Block() repeatuntil servSoc>>RTPSoc.state ne stateListening
   if controlLock eq idle break  //open connection
   CloseRTPSocket(servSoc, 0)  //refuse connection
   ] repeat
controlLock = server
let diskSS, netSS = 0, CreateNetSS(servSoc)
netSS>>SS.type = ssNetPhys
PutTemplate(dsp, "*NConnection open with $P", PrintPort,
 lv servSoc>>BSPSoc.frnPort)

   [  // repeat
   let cd = GetBlock(0, false); if cd eq 0 break
   switchon cd>>CD.type into
      [
      case version:
         [
         PutString(version, cdVersion, versionText)
         endcase
         ]
      case login:
         [
         if (lv cd>>CD.string)>>String.length ne 0 then
            PutTemplate(dsp, "*NLogin user '$S'", lv cd>>CD.string.string)
         PutString(yes, 0, "login ignored")
         endcase
         ]
      case hereAreDiskParams:
         [
         if diskSS>>SS.dp ne 0 then Free(sysZone, diskSS>>SS.dp)
         diskSS>>SS.dp = Allocate(sysZone, cd>>CD.length)
         MoveBlock(diskSS>>SS.dp, cd, cd>>CD.length)
         endcase
         ]
      case sendDiskParamsR: case sendDiskParamsW:
         [
         PutTemplate(dsp, "*NTell me about '$S'", lv cd>>CD.string)
         if diskSS ne 0 then (diskSS>>SS.destroy)(diskSS)
         diskSS = MakeSS(lv cd>>CD.string, cd>>CD.type eq sendDiskParamsW)
         CtxRunning>>CDCtx.ss = netSS
         test diskSS eq 0
            ifso PutString(no, 1, "Can't initialize disk")
            ifnot PutBlock(diskSS>>SS.dp)
         endcase
         ]
      case sendErrors:
         [ PutBlock(diskSS>>SS.errors); endcase ]
      case storeDisk:
         [
         test writeProtectFlag
            ifso PutString(no, 3, "Writing not allowed")
            ifnot
               [
               PutTemplate(dsp, "*NWriting $S", diskSS>>SS.device)
               DoIt(netSS, diskSS, true, cd)
               ]
         endcase
         ]
      case retrieveDisk:
         [
         PutTemplate(dsp, "*NReading $S", diskSS>>SS.device)
         DoIt(diskSS, netSS, true, cd)
         endcase
         ]
      default:
         [ PutString(no, 4, "Unknown command"); endcase ]
      ]
   Free(sysZone, cd)
   ] repeat

if netSS ne 0 then netSS = (netSS>>SS.destroy)(netSS)
if diskSS ne 0 then diskSS = (diskSS>>SS.destroy)(diskSS)
Wss(dsp, "*NServer connection closed")
controlLock = idle
] repeat

//----------------------------------------------------------------------------
and MakeNetSS(name, write) = valof
//----------------------------------------------------------------------------
// Called by MakeSS.  Name is "[Host]Device"
// Returns an SS or 0
[
let bracket = 1
for i = 1 to name>>String.length do
   if name>>String.char↑i eq $] then
      [ bracket = i; break ]
let host = ExtractSubstring(name, 2, bracket-1)
let port = vec lenPort
let res = GetPartner(host, dsp, port, 0, socketCD)
Free(sysZone, host)
unless res resultis false

// The following code handles a special case:
//  If the user types [<ourHost>]device, then strip off
//  "[<ourHost>]" and recursively call MakeSS.
let rte = HLookup(pupRT, port>>Port.net)
if rte ne 0 & rte>>RTE.hops eq 0 &
 rte>>RTE.ndb>>NDB.localHost eq port>>Port.host then
   [
   let device = ExtractSubstring(name, bracket+1)
   let res = MakeSS(device, write)
   Free(sysZone, device)
   resultis res
   ]

// open connection...
let soc = Allocate(sysZone, lenBSPSoc)
OpenLevel1Socket(soc, 0, port)
OpenRTPSocket(soc, ctxQ, modeInitAndReturn, 0, OtherPup)
unless valof
   [
   if soc>>RTPSoc.state eq stateOpen then resultis true
   if soc>>RTPSoc.state ne stateRFCOut then
      [
      CloseRTPSocket(soc)
      OpenRTPSocket(soc, ctxQ, modeInitAndReturn, 0, OtherPup)
      ]
   if (kbdAd!3 & 4) eq 0 % (kbdAd!1 & 3) ne 3 resultis false
   Block()
   ] repeat do
      [
      Wss(dsp, "*NConnection attempt failed")
      CloseRTPSocket(soc, 0)
      CloseLevel1Socket(soc)
      Free(sysZone, soc)
      resultis false
      ]

let netSS = CreateNetSS(soc)
netSS>>NetSS.device = ExtractSubstring(name)

// exchange versions
let ok = true
PutString(version, cdVersion, versionText)
let cd = GetBlock(); if cd eq 0 then ok = false
test ok
   ifnot Wss(dsp, "*NConnection refused by remote host")
   ifso if cd>>CD.type ne version % cd>>CD.codeString.code ne cdVersion then
      [
      Wss(dsp, "*NCopyDisk programs are incompatible.")
      ok = false
      ]
if cd ne 0 then Free(sysZone, cd)

// MakeNetSS (cont'd)

// login
if ok then ok = valof
   [
   let uNam = (userName? userName>>String.length rshift 1, 0) +1
   let uPsw = (userPass? userPass>>String.length rshift 1, 0) +1
   let cNam = (connName? connName>>String.length rshift 1, 0) +1
   let cPsw = (connPass? connPass>>String.length rshift 1, 0) +1
   let length = lenString + uNam + uPsw + cNam + cPsw
   let cd = Allocate(sysZone, length); Zero(cd, length)
   cd>>CD.length = length
   let p = lv cd>>CD.string.string
   if userName then CopyString(p, userName)
   p = p + uNam
   if userPass then CopyString(p, userPass)
   p = p + uPsw
   if connName then CopyString(p, connName)
   p = p + cNam
   if connPass then CopyString(p, connPass)
   PutBlock(cd, login)
   Free(sysZone, cd)

   cd = GetBlock(); if cd eq 0 resultis false
   let type = cd>>CD.type
   let code = cd>>CD.codeString.code
   Free(sysZone, cd)
   if type eq yes resultis true
   switchon code into
      [
      case 20b: case 21b: case 2:
         [
         unless GetNamePass("*NLogin user: ",
          lv userName, lv userPass) resultis false
         endcase
         ]
      case 23b: case 24b:
         [
         unless GetNamePass("*NConnect to directory: ",
          lv connName, lv connPass) resultis false
         endcase
         ]
      ]
   ] repeat

if ok then ok = valof  // get disk parameters
   [
   let device = ExtractSubstring(name, bracket+1)
   let length = lenString + device>>String.length rshift 1 +1
   let cd = Allocate(sysZone, length)
   cd>>CD.length = length
   CopyString(lv cd>>CD.string.string, device)
   Free(sysZone, device)
   PutBlock(cd, (write? sendDiskParamsW, sendDiskParamsR))
   Free(sysZone, cd)
   netSS>>SS.dp = GetBlock()
   if netSS>>SS.dp eq 0 % netSS>>SS.dp>>CD.type ne hereAreDiskParams resultis false
   test netSS>>SS.dp>>CD.diskParams.diskType eq 0
      ifso netSS>>SS.type = ssNetLog
      ifnot
         [
         Puts(dsp, $*N)
         PrintDiskParams(netSS>>SS.dp)
         netSS>>SS.type = ssNetPhys
         ]
   resultis true
   ]

resultis ok? netSS, DestroyNetSS(netSS)
]

//----------------------------------------------------------------------------
and CreateNetSS(soc) = valof
//----------------------------------------------------------------------------
[
let ss = Allocate(sysZone, lenNetSS); Zero(ss, lenNetSS)

ss>>SS.read = NetReader
ss>>SS.write = NetWriter
ss>>SS.destroy = DestroyNetSS
ss>>SS.printDA = NetPrintDA
ss>>SS.compatible = NetCompatible
ss>>SS.compare = NetCompare
ss>>SS.printBlock = NetPrintBlock

ss>>NetSS.soc = soc
let stream = CreateBSPStream(soc)
ss>>NetSS.stream = stream
CtxRunning>>CDCtx.ss = ss
resultis ss
]

//----------------------------------------------------------------------------
and DestroyNetSS(ss) = valof
//----------------------------------------------------------------------------
[
let timeout = ss>>NetSS.stream>>ST.gets eq TruePredicate? 0, defaultTimeout
CloseBSPSocket(ss>>NetSS.soc, timeout)
Free(sysZone, ss>>NetSS.soc)
if ss>>SS.device ne 0 then Free(sysZone, ss>>SS.device)
if ss>>SS.dp ne 0 then Free(sysZone, ss>>SS.dp)
if ss>>SS.errors ne 0 then Free(sysZone, ss>>SS.errors)
Free(sysZone, ss)
resultis 0
]

//----------------------------------------------------------------------------
and OtherPup(pbi) be Enqueue(otherPupQ, pbi)
//----------------------------------------------------------------------------

//----------------------------------------------------------------------------
and OtherPupCtx(ctx) be
//----------------------------------------------------------------------------
// This is a catch-all process.  It prints Error and Abort Pups from
//  BSP connections, it tries to get the string name of this host,
//  and it updates the title line.
[
let soc = vec lenPupSoc; OpenLevel1Socket(soc, 0, table [ 0; 0; 4 ])
let nameTime, nameTimer = 50, nil; SetTimer(lv nameTimer, 500)
let us = vec lenPort; Zero(us, lenPort)
let name, lock, part = ourName, controlLock, Partition()

   [
   if name ne ourName % lock ne controlLock % (ourName eq 0 &
    (us>>Port.net ne (ndbQ!0)>>NDB.localNet %
    us>>Port.host ne (ndbQ!0)>>NDB.localHost)) %
    part ne Partition() then
      [
      Resets(titleDsp)
      InvertLine(titleDsp, GetLinePos(titleDsp))
      Wss(titleDsp, versionText)
      SetBitPos(titleDsp, 250)
      test ourName ne 0
         ifso
            [
            name = ourName
            Wss(titleDsp, ourName)
            ]
         ifnot
            [
            us>>Port.net = (ndbQ!0)>>NDB.localNet
            us>>Port.host = (ndbQ!0)>>NDB.localHost
            PrintPort(titleDsp, us)
            ]
      if part ne 0 then
         [
         part = Partition()
         SetBitPos(titleDsp, 375)
         PutTemplate(titleDsp, "Partition $D", part)
         ]
      lock = controlLock
      if controlLock ne 0 then
         [
         SetBitPos(titleDsp, 525)
         Wss(titleDsp, (controlLock eq server? "Server", "User"))
         ]
      ]

   if otherPupQ!0 ne 0 then
      [
      let pbi = Dequeue(otherPupQ)
      let errorString, startByte = 0, 0
      if pbi>>PBI.pup.type eq typeAbort then
         [ errorString = "*NAbort"; startByte = 3 ]
      if pbi>>PBI.pup.type eq typeError then
         if debugFlag % pbi>>PBI.socket>>BSPSoc.state eq stateAbort then
            [ errorString = "*NError"; startByte = 25 ]
      if startByte ne 0 then
         [
         PutTemplate(dsp, "$S Pup from $P: ", errorString,
          PrintPort, lv pbi>>PBI.pup.sPort)
         for i = startByte to pbi>>PBI.pup.length-pupOvBytes do
            Puts(dsp, pbi>>PBI.pup.bytes↑i)
         ]
      ReleasePBI(pbi)
      ]

// OtherPupCtx (cont'd)

   manifest
      [
      ptAddressLookup = 223b
      ptAddressReply = 224b
      ptNetDirError = 222b
      ]
   if soc>>PupSoc.iQ.head ne 0 then
      [
      let pbi = Dequeue(lv soc>>PupSoc.iQ)
      if ourName eq 0 & pbi>>PBI.pup.type eq ptAddressReply then
         [
         let numChars = pbi>>PBI.pup.length-pupOvBytes+2
         ourName = Allocate(sysZone, numChars/2+1)
         ourName>>String.length = numChars
         ourName>>String.char↑1 = $[
         for i = 1 to numChars-2 do
            ourName>>String.char↑(i+1) = pbi>>PBI.pup.bytes↑i
         ourName>>String.char↑numChars = $]
         ]
      if ourName eq 0 & pbi>>PBI.pup.type eq ptNetDirError then
         [
         let ss = CreateStringStream(lv pbi>>PBI.pup.bytes, 255)
         PrintPort(ss, us)
         Closes(ss)
         ourName = ExtractSubstring(lv pbi>>PBI.pup.bytes)
         ]
      ReleasePBI(pbi)
      ]
   if ourName eq 0 & TimerHasExpired(lv nameTimer) then
      [
      let pbi = GetPBI(soc, true); if pbi ne 0 then
         [
         MoveBlock(lv pbi>>PBI.pup.bytes, us, lenPort)
         CompletePup(pbi, ptAddressLookup, pupOvBytes+6)
         nameTime = nameTime lshift 1
         if nameTime gr 1600 then nameTime = 1600
         SetTimer(lv nameTimer, nameTime)
         ]
      ]
   Dismiss(20)  // 5 times per second
   ] repeat
]

//----------------------------------------------------------------------------
and Partition() = (table [ 61014b; 1401b ])()<<VERS.eng gr 3?
                  (table [ 61037b; 1401b ])(0), 0
//----------------------------------------------------------------------------