// PupBootServ.bcpl -- Boot Server
// See <Pup>AltoBoot.press for protocol specification

// Last modified March 15, 1979  11:37 PM by Boggs

get "Pup0.decl"
get "Pup1.decl"
get "Streams.d"
get "PupBootServ.decl"
get "PupServEftp.decl"

external
[
// outgoing procedures
BootServ; BootServCtx
LockBootServ; UnlockBootServ
StringCompare; DoubleUsc

// incoming procedures
InitializeContext; Dismiss; Block
MoveBlock; Zero; Enqueue; Unqueue; Dequeue
CompletePup; GetPBI; ReleasePBI
ExchangePorts; SetPupDPort; SetPupSPort; SetPupID
CallSwat; DoubleIncrement; Usc; SetTimer; TimerHasExpired
PupServSend; PupServReceive; GetTime
OpenFile; FilePos; SetFilePos; ReadBlock; Resets; Closes
Allocate; Free; DefaultArgs

// outgoing statics
@bs

// incoming statics
ndbQ; lenPup; maxPupDataBytes
bootLoaderPacket; CtxRunning; @ms
]

static @bs

// BootServCtx is the main process for this module.
//  It lives forever and does the following tasks:
//   Broadcasts Boot loaders.
//   Probes for new versions of boot files.
//   Starts a Receiver process when it finds a newer boot file version.
//   Destroys transient processes when they are done.
// There are two types of transient processes:
//  Receivers receive boot files from other boot servers
//  Senders send boot files to:
//   Other boot servers who need to update a boot file.
//   Altos that are requesting a boot.
// There can be at most one receiver process.
// There can be at most two sender processes:
//  At most one sending down an Ethernet (fast net).
//  At most one sending down a net other than an Ethernet (slow net).
// BootServ is logically part of the miscellaneous services process,
//  handling the Boot protocol packet types.
// There are two global locks which if set prevent any more
//  transient processes from being created.
//   Internal lock is set from within the gateway
//   External lock is set by commands from GateControl

//----------------------------------------------------------------------------
let BootServCtx() be
//----------------------------------------------------------------------------
[
Dismiss(breathInterval)

// destroy any contexts which are done
compiletest nova
   ifso
      [
      while bs>>BS.doneQ.head ne 0 do
         ReleasePBI(Dequeue(lv bs>>BS.doneQ)-offset PBI.pup/16)
      ]
   ifnot
      [
      while bs>>BS.doneQ.head ne 0 do
         Free(ms>>MS.zone, Dequeue(lv bs>>BS.doneQ))
      ]

// don't do anything but kill servers if a global lock is set
if bs>>BS.globalLocks ne 0 loop

// run down the list of boot files doing house keeping:
//  1) if any need updating then try to spawn an update process
//  2) if we know the time and any files have dates later than
//     now, set their dates to 0.
let now = vec 1; let knowTime = GetTime(now)
let bfe = bs>>BS.bfeQ.head; while bfe ne 0 do
   [
   if knowTime & DoubleUsc(now, lv bfe>>BFE.date) ls 0 then
      Zero(lv bfe>>BFE.date, 2)
   if bfe>>BFE.update ne 0 then
      CreateBootCtx(ReceiveBootFile, bfe, rcvrLock, lv bfe>>BFE.port)
   bfe = bfe>>BFE.link
   ]

// probe for new boot files now and then
if bs>>BS.bcstTimer gr 0 then
   bs>>BS.bcstTimer = bs>>BS.bcstTimer -1
if bs>>BS.bcstTimer le 0 then SendBootDir(0, 0)

// Every five seconds, broadcast (to host 377) a Breath-of-life NON PUP on
// all directly connected Ethernets containing an Alto Ethernet boot loader.
let ndb = ndbQ!0; while ndb ne 0 do
   [
   if ndb>>NDB.netType eq netTypeEther then
      [
      structure EtherPBI:
         [
         blank word offset PBI.pup/16-2
         dest byte
         src byte
         type word
         ]
      let pbi = GetPBI(ms>>MS.soc, true); if pbi eq 0 break
      pbi>>PBI.ndb = ndb
      pbi>>PBI.packetLength = 256
      MoveBlock(lv pbi>>EtherPBI.dest, bootLoaderPacket, 256)
      pbi>>EtherPBI.dest = 377b  // special for microcode
      pbi>>EtherPBI.src = ndb>>NDB.localHost
      pbi>>EtherPBI.type = etBreathOfLife  // special for microcode
      (ndb>>NDB.level0Transmit)(pbi)
      ]
   ndb = ndb!0
   ]
] repeat

//----------------------------------------------------------------------------
and BootServ(pbi) be
//----------------------------------------------------------------------------
[
ExchangePorts(pbi)
switchon pbi>>PBI.pup.type into
   [
   case ptBootFileRequest:
      [
      if bs>>BS.globalLocks ne 0 endcase
      let bfe = bs>>BS.bfeQ.head; while bfe ne 0 do
         [
         if bfe>>BFE.bfn eq pbi>>PBI.pup.id^2 & bfe>>BFE.exists ne 0 then
            [
            CreateBootCtx(SendBootFile, bfe,
             (pbi>>PBI.ndb>>NDB.netType eq netTypeEther? fastLock, slowLock),
             lv pbi>>PBI.pup.dPort)
            break
            ]
         bfe = bfe>>BFE.link
         ]
      endcase
      ]
   case ptBootDirRequest:
      [
      if bs>>BS.globalLocks eq 0 then
         SendBootDir(lv pbi>>PBI.pup.dPort, lv pbi>>PBI.pup.id)
      endcase
      ]
   case ptBootDirReply:
      [
      if bs>>BS.globalLocks ne 0 endcase
      let now = vec 1; let knowTime = GetTime(now)
      let p = 1; until p ge ((pbi>>PBI.pup.length-pupOvBytes)+1)/2 do
         [
         let bfd = lv pbi>>PBI.pup.words^p
         p = p + lenBFD + bfd>>BFD.name.length rshift 1 +1
         if (bfd>>BFD.bfn & 1b15) ne 0 % not knowTime %
          (knowTime & DoubleUsc(now, lv bfd>>BFD.date) ls 0) loop
         let bfe = bs>>BS.bfeQ.head; while bfe ne 0 do
            [
            if bfe>>BFE.bfn eq bfd>>BFD.bfn then
               [
               if StringCompare(lv bfd>>BFD.name, lv bfe>>BFE.name) ne 0 break
               let dateUsc = DoubleUsc(lv bfd>>BFD.date, lv bfe>>BFE.date)
               if dateUsc ls 0 then bs>>BS.bcstTimer = 0
               if dateUsc gr 0 then
                  [
                  MoveBlock(lv bfe>>BFE.port, lv pbi>>PBI.pup.dPort, lenPort)
                  bfe>>BFE.update = true
                  ]
               break
               ]
            bfe = bfe>>BFE.link
            ]
         ]
      endcase
      ]
   case ptBootStatsRequest:
      [
      MoveBlock(lv pbi>>PBI.pup.words, lv bs>>BS.stats, size Stats/16)
      CompletePup(pbi, ptBootStatsReply, pupOvBytes+size Stats/8)
      return
      ]
   case ptBootLockRequest:
      [
      if Authenticate(pbi) then
         [
         bs>>BS.externalLock = true
         CompletePup(pbi, ptBootLockReply, pupOvBytes)
         return
         ]
      endcase
      ]
   case ptBootUnlockRequest:
      [
      if Authenticate(pbi) then
         [
         bs>>BS.externalLock = false
         bs>>BS.bcstTimer = 0
         CompletePup(pbi, ptBootUnlockReply, pupOvBytes)
         return
         ]
      endcase
      ]
   ]
ReleasePBI(pbi)
]

//----------------------------------------------------------------------------
and Authenticate(pbi) = pbi>>PBI.pup.id^1 eq 27182
//----------------------------------------------------------------------------

//----------------------------------------------------------------------------
and SendBootDir(port, id) be
//----------------------------------------------------------------------------
// Send the boot file directory to port.  Set the pup IDs to id.
// If port is 0, then broadcast it on all directly connected nets.
[
let allNets = port eq 0
test port eq 0
   ifso
      [
      port = table [ 0; 0; psMiscServ ]
      id = table [ 0; 0 ]
      bs>>BS.bcstTimer = bs>>BS.bcstInterval
      ]
   ifnot DoubleIncrement(lv bs>>BS.stats.dirsSent)

let pbi, p = 0, nil  // p indexes pbi: pbi>>PBI.pup.words^p
let bfe = bs>>BS.bfeQ.head; while bfe ne 0 do
   [
   if bfe>>BFE.exists then
      [
      if pbi eq 0 then
         [
         pbi = GetPBI(ms>>MS.soc, true); if pbi eq 0 return
         SetPupDPort(pbi, port)
         SetPupID(pbi, id)
         pbi>>PBI.allNets = allNets
         p = 0
         ]
      let lBFD = lenBFD + bfe>>BFE.name.length/2 +1
      if (p+lBFD) gr maxPupDataBytes/2 then
         [  //ran out of space in this packet
         CompletePup(pbi, ptBootDirReply, pupOvBytes+p*2)
         pbi = 0
         loop
         ]
      MoveBlock(lv pbi>>PBI.pup.words^(p+1), lv bfe>>BFE.bfd, lBFD)
      p = p + lBFD
      ]
   bfe = bfe>>BFE.link
   ]

if pbi ne 0 then CompletePup(pbi, ptBootDirReply, pupOvBytes+p*2)
]

//----------------------------------------------------------------------------
and ReceiveBootFile(ctx) be	// a BCTX
//----------------------------------------------------------------------------
[
let bfe = ctx>>BCTX.bfe
let eftp = vec lenEFTP; Zero(eftp, lenEFTP)
eftp>>EFTP.frnPort = lv ctx>>BCTX.port
eftp>>EFTP.fp = lv bfe>>BFE.fp
eftp>>EFTP.realName = lv bfe>>BFE.name
eftp>>EFTP.tempName = "TEMP.BOOT"
eftp>>EFTP.timeOut1 = 100  // 1 sec
eftp>>EFTP.timeOut2 = 2000  // 20 sec
eftp>>EFTP.proc1 = RBFStartProc
eftp>>EFTP.proc2 = RBFEndProc
if PupServReceive(eftp) then
   [
   DoubleIncrement(lv bs>>BS.stats.filesRcvd)
   SendBootDir(0, 0)
   ]
//even if we fail, wait for receipt of next boot dir bcst before trying again
bfe>>BFE.update = false
DestroyBootCtx(ctx)
//returning from a context does an implicit Block()
]

//----------------------------------------------------------------------------
and RBFStartProc(soc) be
//----------------------------------------------------------------------------
[
let pbi = GetPBI(soc, true); if pbi eq 0 return
pbi>>PBI.pup.id^2 = CtxRunning>>BCTX.bfe>>BFE.bfn
CompletePup(pbi, ptBootFileRequest, pupOvBytes)
]

//----------------------------------------------------------------------------
and RBFEndProc(stream) be
//----------------------------------------------------------------------------
[
let fPos = vec 1; FilePos(stream, fPos)
Resets(stream)
let v = vec 5; ReadBlock(stream, v, 5)
MoveBlock(lv CtxRunning>>BCTX.bfe>>BFE.date, v+3, 2)
CtxRunning>>BCTX.bfe>>BFE.exists = true
SetFilePos(stream, fPos)
]

//----------------------------------------------------------------------------
and SendBootFile(ctx) be	// a BCTX
//----------------------------------------------------------------------------
[
let eftp = vec lenEFTP; Zero(eftp, lenEFTP)
eftp>>EFTP.frnPort = lv ctx>>BCTX.port
eftp>>EFTP.fp = lv ctx>>BCTX.bfe>>BFE.fp
eftp>>EFTP.realName = lv ctx>>BCTX.bfe>>BFE.name
let fast = ctx>>BCTX.lockMask eq fastLock
eftp>>EFTP.timeOut1 = fast? 50, 3000  //1/2, 30
eftp>>EFTP.timeOut2 = fast? 500, 3000  //5, 30
if PupServSend(eftp) then
   DoubleIncrement(fast? lv bs>>BS.stats.fastSends, lv bs>>BS.stats.slowSends)
DestroyBootCtx(ctx)
//returning from a context does an implicit Block()
]

//----------------------------------------------------------------------------
and CreateBootCtx(proc, bfe, lockMask, port) be
//----------------------------------------------------------------------------
[
if bs>>BS.globalLocks ne 0 % (bs>>BS.localLocks & lockMask) ne 0 return
bs>>BS.localLocks = bs>>BS.localLocks % lockMask

let ctx = alto? Allocate(ms>>MS.zone, 1200, true), valof  //nova case
   [  //locks set above because GetPBI can call Block.
   let pbi = GetPBI(ms>>MS.soc, true)
   resultis pbi eq 0? 0, lv pbi>>PBI.pup
   ]

test ctx ne 0
   ifso
      [
      InitializeContext(ctx, (alto? 1200, lenPup), proc, BCTXextra)
      ctx>>BCTX.bfe = bfe
      ctx>>BCTX.lockMask = lockMask
      MoveBlock(lv ctx>>BCTX.port, port, lenPort)
      Enqueue(ms>>MS.ctxQ, ctx)
      ]
   ifnot bs>>BS.localLocks = bs>>BS.localLocks & not lockMask
]

//----------------------------------------------------------------------------
and DestroyBootCtx(ctx) be
//----------------------------------------------------------------------------
// This doesn't actually destroy it.  It releases ctx's locks
//  and queues it for destruction by BootCtx.
[
Unqueue(ms>>MS.ctxQ, ctx)
Enqueue(lv bs>>BS.doneQ, ctx)
bs>>BS.localLocks = bs>>BS.localLocks & not ctx>>BCTX.lockMask
]

//----------------------------------------------------------------------------
and LockBootServ() be
//----------------------------------------------------------------------------
// No further transient processes will be created.
// Returns when none are active.
[
bs>>BS.internalLock = true
Block() repeatuntil bs>>BS.localLocks eq 0
]

//----------------------------------------------------------------------------
and UnlockBootServ(name; numargs na) be
//----------------------------------------------------------------------------
[
if na gr 0 then
   [
   let bfe = bs>>BS.bfeQ.head; while bfe ne 0 do
      [
      if StringCompare(name, lv bfe>>BFE.name) eq 0 then
         [
         Zero(lv bfe>>BFE.fp, 5)
         let stream = OpenFile(name, ksTypeReadOnly, charItem,
          0, lv bfe>>BFE.fp)
         if stream ne 0 then
            [
            let v = vec 5; ReadBlock(stream, v, 5)
            MoveBlock(lv bfe>>BFE.date, v+3, 2)
            Closes(stream)
            bfe>>BFE.exists = true
            bs>>BS.bcstTimer = 0
            ]
         break
         ]
      bfe = bfe>>BFE.link
      ]
   ]
bs>>BS.internalLock = false
]

//----------------------------------------------------------------------------
and StringCompare(s1, s2, first1, last1, first2, last2; numargs na) = valof
//----------------------------------------------------------------------------
//Compares the "first1" through "last1" characters of the string
//"s1" with the "first2" through "last2" characters of "s2",
//with lower-case alphabetics matching upper-case.  Returns a code
//describing the result:
// -2	s1 is an initial substring of s2
// -1	s1 is "less than" s2 but not an initial substring
//  0	s1 is "equal to" s2
//  1	s1 is "greater than" s2
//The arguments beyond "s2" are optional and default to the entire
//respective string.
[
DefaultArgs(lv na, -2, 1, s1>>String.length, 1, s2>>String.length)
let firstDif = first2-first1
for i = first1 to last1 do
   [
   if i gr last2-firstDif resultis 1
   let c1 = s1>>String.char^i
   if c1 ge $a & c1 le $z then c1 = c1-($a-$A)
   let c2 = s2>>String.char^(firstDif+i)
   if c2 ge $a & c2 le $z then c2 = c2-($a-$A)
   if c1 ne c2 resultis Usc(c1, c2)
   ]
resultis (last2-last1 eq firstDif? 0, -2)
]

//----------------------------------------------------------------------------
and DoubleUsc(lvA, lvB) =
//----------------------------------------------------------------------------
// lvA and lvB are the addresses of two 32-bit operands Returns:
//	-1 if A < B
//	 0 if A = B
//	 1 if A > B
(table
   [
    41003b	//	sta 0 3 2	; lvA
    45002b	//	sta 1 2 2	; lvB
    23003b	//	lda 0 @3 2	; A high part
    27002b	//	lda 1 @2 2	; B high part
   106414b	//	se 0 1		; A, B
      405b	//	 jmp dusc1
    11003b	//	isz 3 2		; lvA
    11002b	//	isz 2 2		; lvB
    23003b	//	lda 0 @3 2	; A low part
    27002b	//	lda 1 @2 2	; B low part
   106433b	// dusc1: sleu 0 1	; A, B
      405b	//	 jmp gr		; A > B
   106414b	//	se 0 1		; A, B
   102001b	//	 mkminusone 0 0 skp	; A < B
   102460b	//	mkzero 0 0	; A = B
     1401b	//	jmp 1 3
   102520b	// gr:	mkone 0 0
     1401b	//	jmp 1 3
   ])(lvA, lvB)