// IfsNameRare.bcpl - Name lookup server
// Copyright Xerox Corporation 1979, 1980, 1981 
// Last modified December 5, 1981  3:00 PM by Taft

get "Pup0.decl"
get "Pup1.decl"
get Lock from "Ifs.decl"
get "IfsNameServ.decl"
get "IfsServEFTP.decl"
get "IfsDirs.decl"
get "IfsRs.decl"

external
[
// outgoing procedures
CreateNameServ; EnableNameServ; NameServUncommon; CheckNetDirChecksum
NameServEvent; SendNetDir; ReceiveNetDir

// incoming procedures
InstallNetworkDirectory
OpenLevel1Socket; CloseLevel1Socket
GetPBI; ReleasePBI; CompletePup
PupServSend; PupServReceive
CreateEvent; QueueEvent; CreateJob; DestroyJob
LnPageSize; Closes; Resets
FileLength; SetFilePos; KsBufferAddress
CreateStringStream; PutTemplate
SetTimer; TimerHasExpired; Block; Dequeue; IFSError
Min; Max; DoubleDifference; DoubleIncrement
SysAllocateZero; SysFree; Usc; MoveBlock; Zero; Noop

// incoming statics
@ns; system; CtxRunning
]

//----------------------------------------------------------------------------
structure NameCtx:
//----------------------------------------------------------------------------
[
@RSCtx
reqPort @Port =		// port of guy who wants our directory
   [
   ftp word		// -> FTP structure for receiving net dir
   version word		// version we expect to receive
   ]
]
manifest lenNameCtx = size NameCtx/16

//----------------------------------------------------------------------------
let CreateNameServ() be
//----------------------------------------------------------------------------
[
ns = SysAllocateZero(lenNS)
ns>>NS.stats.version = nameStatsVersion
ns>>NS.bcstInterval = 12  // 1 hour between broadcasts

CreateEvent(NameServEvent)
]

//----------------------------------------------------------------------------
and EnableNameServ(value) be ns>>NS.externalLock = not value
//----------------------------------------------------------------------------

//----------------------------------------------------------------------------
and NameServUncommon(pbi) be
//----------------------------------------------------------------------------
// Handles uncommon Name protocol pbis that pop out of the Miscellaneous
// socket.  Note that an ExchangePorts has already been done.
[
switchon pbi>>PBI.pup.type into
   [
   case ptNetDirVersion:
      switchon Usc(pbi>>PBI.pup.words↑1, ns>>NS.version) into
         [
         case -1:  // tell him we have a later version
            if ns>>NS.globalLocks eq 0 & ns>>NS.tree ne 0 then
               [
               pbi>>PBI.pup.words↑1 = ns>>NS.version
               CompletePup(pbi, ptNetDirVersion, pupOvBytes+2)
               return
               ]
            endcase
         case 1:  // he claims to have a later version
            CreateNameCtx(ReceiveNetDir)
            endcase
         // case 0:  // our versions are the same
         //    endcase
         ]
      endcase

   case ptSendNetDir:
      if ns>>NS.globalLocks eq 0 then
         CreateNameCtx(SendNetDir, lv pbi>>PBI.pup.words↑1)
      endcase

   case ptNetDirStatsRequest:
      MoveBlock(lv pbi>>PBI.pup.words, lv ns>>NS.stats, size Stats/16)
      CompletePup(pbi, ptNetDirStatsReply, pupOvBytes+size Stats/8)
      return

   case ptNetDirLockRequest:
   case ptNetDirUnlockRequest:
      [
      if pbi>>PBI.pup.id↑1 eq 27182 & pbi>>PBI.pup.sPort.host ne 0 then
         [
         let unlock = pbi>>PBI.pup.type eq ptNetDirUnlockRequest
         ns>>NS.bcstTimer = 0
         EnableNameServ(unlock)
         CompletePup(pbi, (unlock? ptNetDirUnlockReply, ptNetDirLockReply),
          pupOvBytes)
         return
         ]
      endcase
      ]
   ]
ReleasePBI(pbi)
]

//----------------------------------------------------------------------------
and NameServEvent(ecb) be
//----------------------------------------------------------------------------
[
ns>>NS.bcstTimer = Max(ns>>NS.bcstTimer-1, 0)
if ns>>NS.bcstTimer eq 0 then
   CreateNameCtx(ReceiveNetDir)

QueueEvent(ecb, 30000)  // 5 minutes
]

//----------------------------------------------------------------------------
and CreateNameCtx(Proc, reqPort) be
//----------------------------------------------------------------------------
[
if ns>>NS.ctx ne 0 return
let ctx = CreateJob(Proc, jobTypeNameUpdate, lenNameCtx-3)
if ctx ne 0 then
   [
   ns>>NS.ctx = ctx
   ctx>>NameCtx.userInfo = system
   MoveBlock(lv ctx>>NameCtx.reqPort, reqPort, lenPort)
   ]
]

//----------------------------------------------------------------------------
and SendNetDir(ctx) be	// a context
//----------------------------------------------------------------------------
[
let ftp = vec lenFTP
Zero(ftp, lenFTP)
ftp>>FTP.frnPort = lv ctx>>NameCtx.reqPort
ftp>>FTP.realName = "Pup-Network.directory"
ftp>>FTP.timeOut1 = 1000
ftp>>FTP.timeOut2 = 1000
if PupServSend(ftp) then DoubleIncrement(lv ns>>NS.stats.dirReqs)
ns>>NS.ctx = 0
DestroyJob()
]

//----------------------------------------------------------------------------
and ReceiveNetDir(ctx) be	// a context
//----------------------------------------------------------------------------
// Probe all name servers on all directly connected networks.
// If we locate a newer version, get it.
[
ns>>NS.bcstTimer = ns>>NS.bcstInterval

// When IFS is first started up, the directory is not yet installed, so...
if ns>>NS.tree eq 0 then InstallNetworkDirectory()

let soc = vec lenPupSoc
OpenLevel1Socket(soc, 0, table [ 0; 0; socketMiscServices ], true)
let pbi = GetPBI(soc)
pbi>>PBI.pup.words↑1 = ns>>NS.globalLocks eq 0? ns>>NS.version, 0
CompletePup(pbi, ptNetDirVersion, pupOvBytes+2)

let bestSoFar = ns>>NS.version
let timer = nil; SetTimer(lv timer, 1000)  //10 seconds
let frnPort = vec lenPort 
   [
   Block()
   until soc>>PupSoc.iQ.head eq 0 do
      [
      let pbi = Dequeue(lv soc>>PupSoc.iQ)
      if pbi>>PBI.pup.type eq ptNetDirVersion &
       pbi>>PBI.pup.words↑1 ugr bestSoFar then
         [
         bestSoFar = pbi>>PBI.pup.words↑1
         MoveBlock(frnPort, lv pbi>>PBI.pup.sPort, lenPort)
         ]
      ReleasePBI(pbi)
      ]
   ] repeatuntil TimerHasExpired(lv timer)

CloseLevel1Socket(soc)

if bestSoFar ugr ns>>NS.version then
   [
   let ftp = vec lenFTP; Zero(ftp, lenFTP)
   ftp>>FTP.frnPort = frnPort
   let realName = vec 15
   ftp>>FTP.realName = realName  // NSEndProc will generate the realName
   ftp>>FTP.tempName = "Pup-Network.temp"
   ftp>>FTP.timeOut1 = 100
   ftp>>FTP.timeOut2 = 3000  // 30 seconds
   ftp>>FTP.proc1 = NSStartProc
   ftp>>FTP.proc2 = NSEndProc
   ctx>>NameCtx.ftp = ftp  // so NSEndProc can find it
   ctx>>NameCtx.version = bestSoFar
   if PupServReceive(ftp) then
      if InstallNetworkDirectory() then loop  // notify world
   ]

ns>>NS.ctx = 0
DestroyJob()
] repeat

//----------------------------------------------------------------------------
and NSStartProc(soc) be
//----------------------------------------------------------------------------
[
let pbi = GetPBI(soc, true); if pbi ne 0 then
   [
   MoveBlock(lv pbi>>PBI.pup.words, lv soc>>PupSoc.lclPort, lenPort)
   CompletePup(pbi, ptSendNetDir, pupOvBytes + lenPort*2)
   ]
]

//----------------------------------------------------------------------------
and NSEndProc(stream) = valof
//----------------------------------------------------------------------------
[
Resets(stream)
unless KsBufferAddress(stream)>>Hdr.version eq CtxRunning>>NameCtx.version &
 CheckNetDirChecksum(stream) resultis false
let ss = CreateStringStream(CtxRunning>>NameCtx.ftp>>FTP.realName, 30)
PutTemplate(ss, "Pup-Network.directory!$UD", CtxRunning>>NameCtx.version)
Closes(ss)
resultis true
]

//----------------------------------------------------------------------------
and CheckNetDirChecksum(stream) = valof
//----------------------------------------------------------------------------
// stream should be a stream open on the file.
// Returns true iff the file's checksum is ok.
// Leaves the stream positioned at end-of-file.
[
let length = vec 1
FileLength(stream, length)
let pageLength = 2 lshift LnPageSize(stream)
let buffer = KsBufferAddress(stream)
let checksum = 0
let fileChecksum = nil
let pos = vec 1
Zero(pos, 2)

   [ // repeat
   SetFilePos(stream, pos)
   let remainder = DoubleDifference(length, pos)
   if remainder eq 0 break
   let byteCount = Min(remainder, pageLength)
   let wordCount = byteCount rshift 1
   if remainder le pageLength then
      [ // this is the last (non-empty) page of the file
      wordCount = wordCount-1
      fileChecksum = buffer!wordCount
      ]
   if wordCount gr 0 then
      checksum = (table
         [
          55001b	// sta 3 1 2
          35003b	// lda 3 3 2
          63000b	// pupChecksum
          35001b	// lda 3 1 2
           1401b	// jmp 1 3
         ])(checksum, buffer, wordCount)
   DoubleIncrement(pos, byteCount)
   ] repeat

resultis checksum eq fileChecksum
]