// PupNameCore.bcpl - Name lookup server
// See also PupNameServ.bcpl, PupNameInit.bcpl PupNameServ.decl
// Last modified June 30, 1982  10:02 AM by Taft

get "Pup0.decl"
get "Pup1.decl"
get "Streams.d"
get "PupNameServ.decl"

external
[
// outgoing procedures
LockNameServ; UnlockNameServ; NameLookup

// incoming procedures
OpenFile; Closes; Gets; SetFilePos; ReadBlock
MoveBlock; Zero; MultEq; Min; Umin; Umax; DoubleIncrement
Enqueue; Dequeue; Unqueue; InsertAfter
InitializeZone; Allocate; Free; CallSwat; Block
Dismiss; GetPBI; ReleasePBI
CompletePup; AppendStringToPup

// incoming statics
lenPup; @ms; @ns
]

//----------------------------------------------------------------------------
let LockNameServ(lockMask; numargs na) be
//----------------------------------------------------------------------------
// Shut down the name server, returning when everything has stopped.
// Special case: if an arument is passed, then one of the transient
//  processes wants to lock it, so ignore his local lock.
[
ns>>NS.internalLock = true
Block() repeatuntil ns>>NS.localLocks eq (na eq 1? lockMask, 0)
if ns>>NS.stream ne 0 then
   [
   Closes(ns>>NS.stream)
   ns>>NS.stream = 0
   ]
]

//----------------------------------------------------------------------------
and UnlockNameServ() be
//----------------------------------------------------------------------------
[
ns>>NS.internalLock = false
ns>>NS.name = alto? "Pup-Network.directory", "PUPNET.DIR"

// Open the directory file and read its header block
Zero(lv ns>>NS.fp, 5)
ns>>NS.stream = OpenFile(ns>>NS.name, ksTypeReadOnly, charItem,
 0, lv ns>>NS.fp)
if ns>>NS.stream eq 0 return
ReadBlock(ns>>NS.stream, ns>>NS.header, lenHdr)

// Read the name lookup table and save the positions of the first
// and last name blocks.  Use cacheZone as a temporary buffer.
SetDirPos(ns>>NS.header>>Hdr.firstName)
let left = ns>>NS.header>>Hdr.numNames
let cacheZone = ns>>NS.cacheZone
let firstNamePos = 177777b
let lastNamePos = 0
while left gr 0 do
   [
   Dismiss(1)
   ReadBlock(ns>>NS.stream, cacheZone, lenCacheZone)
   for i = 0 to Min(left, lenCacheZone)-1 do
      [
      firstNamePos = Umin(firstNamePos, cacheZone!i)
      lastNamePos = Umax(lastNamePos, cacheZone!i)
      ]
   left = left-lenCacheZone
   ]
ns>>NS.firstNamePos = firstNamePos
ns>>NS.lastNamePos = lastNamePos

// Invalidate and reinitialize the cache
ns>>NS.cneQ.head = 0
InitializeZone(ns>>NS.cacheZone, lenCacheZone)
]

//----------------------------------------------------------------------------
and NameLookup(pbi) be
//----------------------------------------------------------------------------
[
if ns>>NS.stream eq 0 then [ ReleasePBI(pbi); return ]

// get some PBIs for buffers - punt if none left
ns>>NS.lkupLock = true
ns>>NS.firstPBI = GetPBI(ms>>MS.soc, true)
ns>>NS.secondPBI = GetPBI(ms>>MS.soc, true)
if ns>>NS.firstPBI eq 0 % ns>>NS.secondPBI eq 0 then
   [
   ReleasePBI(pbi)
   if ns>>NS.firstPBI ne 0 then ReleasePBI(ns>>NS.firstPBI)
   if ns>>NS.secondPBI ne 0 then ReleasePBI(ns>>NS.secondPBI)
   ns>>NS.lkupLock = false
   return
   ]

let buffer = lv ns>>NS.firstPBI>>PBI.pup
DoubleIncrement(lv ns>>NS.stats.nameReqs)

// initialize queues
ns>>NS.freeAddrQ.head = 0
ns>>NS.oldAddrQ.head = 0
ns>>NS.newAddrQ.head = 0
let i = lenString
while i ls lenPup-lenAddr do
   [ Enqueue(lv ns>>NS.freeAddrQ, buffer+i); i = i+lenAddr ]
Enqueue(lv ns>>NS.oldAddrQ, GetItem())  // initialize to a single zero item

// Parse the name string
let length = pbi>>PBI.pup.length-pupOvBytes
if length le 0 % length gr 255 then
   [ ReturnError(pbi, "Illegal name"); return ]

let bytePos = 0
let endOfData = false
let port = vec lenPort
until endOfData do
   [
   // Collect text up to next $+ or end of string
   bytePos = bytePos+1 //skip previous $+
   let byteCount = 0
   let char = pbi>>PBI.pup.bytes↑bytePos
   while char ne $+ do
      [
      if char ne $*s then
         [
         byteCount = byteCount+1
         if char ge $a & char le $z then char = char-($a-$A)
         if char ls #40 % char ge #177 then
            [ ReturnError(pbi, "Illegal character in name"); return ]
         buffer>>String.char↑byteCount = char
         ]
      if bytePos ge length then [ endOfData = true; break ]
      bytePos = bytePos+1; char = pbi>>PBI.pup.bytes↑bytePos
      ]
   buffer>>String.length = byteCount
   buffer>>String.char↑(byteCount+1) = 0  //ensure leftover byte zero

   // Try to parse as address constant
   if ParseAddressConstant(buffer, port) then
      [ CrossPort(port); ResetAddrQueues(); loop ]

// NameLookup (cont'd)

   // Not address constant.  Lookup name in cache
   let cne = SearchNameCache(buffer)
   if cne eq 0 then
      [
      // Not in cache, search the directory on the disk
      let name = SearchNetDir(buffer)

      // Insert name into cache.  Note that we do this whether or not
      // it was found on the disk.  This is so that retransmissions of
      // a failing lookup request will not result in repeated disk searches.
      cne = InsertNameInCache(buffer)

      // If the name was actually found, insert the corresponding
      // address entries into the cache also.
      if name ne 0 then
         [
         let addrPos = ReadDir(name>>Name.entry+addrOffset)
         while addrPos ne 0 do
            [
            SetDirPos(addrPos)
            let addr = vec lenAddr
            ReadBlock(ns>>NS.stream, addr, lenAddr)
            InsertAddrInCache(cne, lv addr>>Addr.port)
            addrPos = addr>>Addr.link
            ]
         ]
      ]

   // cne now points to cache entry for matching name.
   let cae = cne>>CNE.cae
   if cae eq 0 then
      [ ReturnError(pbi, "Name not found"); return ]

   // Compute intersection of new entry with preceding terms of
   // the name expression.
   while cae ne 0 do
      [
      CrossPort(lv cae>>CAE.port)
      cae = cae>>CAE.link
      ]
   ResetAddrQueues()
   ]

// Reached end of request string.  If queue is empty, the intersection
// of terms in the expression was empty.  This is an error.
if ns>>NS.oldAddrQ.head eq 0 then
   [ ReturnError(pbi, "Inconsistent expression"); return ]

// Construct reply packet
i = 1
   [
   let addr = Dequeue(lv ns>>NS.oldAddrQ)
   if addr eq 0 break
   MoveBlock(lv pbi>>PBI.pup.words↑i, lv addr>>Addr.port, lenPort)
   i = i + lenPort
   ] repeat
CompleteNameReq(pbi, ptNetDirReply, pupOvBytes+(i-1)*2)
]

//----------------------------------------------------------------------------
and ReturnError(pbi, message) be
//----------------------------------------------------------------------------
[
AppendStringToPup(pbi, 1, message)
CompleteNameReq(pbi, ptNetDirError, pbi>>PBI.pup.length)
]

//----------------------------------------------------------------------------
and CompleteNameReq(pbi, type, length) be
//----------------------------------------------------------------------------
[
CompletePup(pbi, type, length)
ReleasePBI(ns>>NS.firstPBI)
ReleasePBI(ns>>NS.secondPBI)
ns>>NS.lkupLock = false
]

//--------------------------------------------------------------------------
and SearchNameCache(name) = valof
//--------------------------------------------------------------------------
// Searches for name in cache.  If found, returns pointer to cache name
// entry (cne).  If not found, returns zero.
// Assumes name has been converted to upper-case and that the leftover byte
// at the end, if present, is zero.
[
let lenName = name>>String.length rshift 1 +1
let cne = ns>>NS.cneQ.head; while cne ne 0 do
   [
   if MultEq(name, lv cne>>CNE.string, lenName) then
      [  // Found, insert cache entry at front of queue
      Unqueue(lv ns>>NS.cneQ, cne)
      InsertAfter(lv ns>>NS.cneQ, lv ns>>NS.cneQ, cne)
      DoubleIncrement(lv ns>>NS.stats.cacheHits)
      resultis cne
      ]
   cne = cne>>CNE.link
   ]
DoubleIncrement(lv ns>>NS.stats.cacheMisses)
resultis 0
]

//--------------------------------------------------------------------------
and InsertNameInCache(name) = valof
//--------------------------------------------------------------------------
// Creates and returns a cache name entry (cne) containing the supplied
// name string, which is assumed to be all upper-case with the leftover
// byte zeroed.
[
let lenName = name>>String.length rshift 1 +1
let cne = CacheAllocate(lenCNEHeader+lenName)
cne>>CNE.cae = 0
MoveBlock(lv cne>>CNE.string, name, lenName)
InsertAfter(lv ns>>NS.cneQ, lv ns>>NS.cneQ, cne)  // Insert at front of queue
resultis cne
]

//--------------------------------------------------------------------------
and InsertAddrInCache(cne, port) be
//--------------------------------------------------------------------------
// Creates a cache address entry (cae) and appends it to the queue rooted
// in the supplied cne.
[
let cae = CacheAllocate(lenCAE)
MoveBlock(lv cae>>CAE.port, port, lenPort)
cae>>CAE.link = 0
let lvCAE = lv cne>>CNE.cae
while lvCAE!0 ne 0 do lvCAE = lvCAE!0
lvCAE!0 = cae
]

//--------------------------------------------------------------------------
and CacheAllocate(nWords) = valof
//--------------------------------------------------------------------------
// Allocates nWords words in the cache and returns pointer
[
// Attempt to allocate the block
let block = Allocate(ns>>NS.cacheZone, nWords, true)
if block ne 0 resultis block

// Failed.  Flush one cache entry from tail of queue and try again
if ns>>NS.cneQ.head eq 0 then CallSwat("[CacheAllocate] cneQ empty")
let cne = ns>>NS.cneQ.tail
Unqueue(lv ns>>NS.cneQ, cne)
let cae = cne>>CNE.cae
Free(ns>>NS.cacheZone, cne)
while cae ne 0 do
   [
   let t = cae>>CAE.link
   Free(ns>>NS.cacheZone, cae)
   cae = t
   ]
Block()
] repeat

//----------------------------------------------------------------------------
and ParseAddressConstant(string, port) = valof
//----------------------------------------------------------------------------
// Parses a network address constant of the form
//	net#host#socket and sets port accordingly
// Returns:
//	true if string had correct syntax
//	false otherwise
[
Zero(port, lenPort)
let c, len = 0, string>>String.length
   [
   let char = nil
      [
      c = c+1; if c gr len resultis true
      char = string>>String.char↑c
      ] repeatwhile char eq $*s
   while char ge $0 & char le $7 do
      [
      if (port>>Port.socket↑1 & #160000) ne 0 resultis false
      port>>Port.socket↑1 = port>>Port.socket↑1 lshift 3 +
       port>>Port.socket↑2 rshift 13
      port>>Port.socket↑2 = port>>Port.socket↑2 lshift 3 + char-$0
      c = c+1; if c gr len resultis true
      char = string>>String.char↑c
      ]
   while char eq $*s do
      [
      c = c+1; if c gr len resultis true
      char = string>>String.char↑c
      ]
   if char ne $# % port>>Port.net ne 0 % port>>Port.socket↑1 ne 0
    % (port>>Port.socket↑2 & #177400) ne 0 resultis false
   port>>Port.net = port>>Port.host
   port>>Port.host = port>>Port.socket↑2
   port>>Port.socket↑1 = 0; port>>Port.socket↑2 = 0
   ] repeat
]

//----------------------------------------------------------------------------
and CrossPort(port) be
//----------------------------------------------------------------------------
[
let t = ns>>NS.oldAddrQ.head; while t ne 0 do
   [
   unless (t>>Addr.port.net ne 0 & port>>Port.net ne 0 &
           t>>Addr.port.net ne port>>Port.net ) %
          (t>>Addr.port.host ne 0 & port>>Port.host ne 0 &
           t>>Addr.port.host ne port>>Port.host ) %
          ((t>>Addr.port.socket↑1 ne 0 % t>>Addr.port.socket↑2 ne 0) &
           (port>>Port.socket↑1 ne 0 % port>>Port.socket↑2 ne 0) &
           (t>>Addr.port.socket↑1 ne port>>Port.socket↑1 %
            t>>Addr.port.socket↑2 ne port>>Port.socket↑2)) do
      [
      let i = GetItem()
      i>>Addr.port.net = t>>Addr.port.net % port>>Port.net
      i>>Addr.port.host = t>>Addr.port.host % port>>Port.host
      i>>Addr.port.socket↑1 = t>>Addr.port.socket↑1 % port>>Port.socket↑1
      i>>Addr.port.socket↑2 = t>>Addr.port.socket↑2 % port>>Port.socket↑2
      Enqueue(lv ns>>NS.newAddrQ, i)
      ]
   t = t>>Addr.link
   ]
]

//----------------------------------------------------------------------------
and ResetAddrQueues() be
//----------------------------------------------------------------------------
//flush oldAddrQ and then move contents of newAddrQ to oldAddrQ
[
while ns>>NS.oldAddrQ.head ne 0 do
   Enqueue(lv ns>>NS.freeAddrQ, Dequeue(lv ns>>NS.oldAddrQ))
MoveBlock(lv ns>>NS.oldAddrQ, lv ns>>NS.newAddrQ, 2)
ns>>NS.newAddrQ.head = 0
]

//----------------------------------------------------------------------------
and GetItem() = valof
//----------------------------------------------------------------------------
[
let item = Dequeue(lv ns>>NS.freeAddrQ)
if item eq 0 then CallSwat("[GetItem] freeAddrQ exhausted")
Zero(item, lenAddr)
resultis item 
]

//----------------------------------------------------------------------------
and ReadDir(pos; numargs na) = valof
//----------------------------------------------------------------------------
[
if na ne 0 then SetDirPos(pos)
let temp = Gets(ns>>NS.stream)
resultis temp lshift 8 + Gets(ns>>NS.stream)
]

//----------------------------------------------------------------------------
and SetDirPos(pos) be
//----------------------------------------------------------------------------
[
Dismiss(1)
// assume file length is less than 2↑16
SetFilePos(ns>>NS.stream, pos rshift 15, pos lshift 1)
]

//--------------------------------------------------------------------------
and SearchNetDir(key) = valof
//--------------------------------------------------------------------------
// Searches the network directory on disk for the specified name.
// If found, returns a pointer to a copy of the matching Name block.
// If not found, returns zero.
// Supplied key must be all upper-case.
[
let nameBlock = lv ns>>NS.secondPBI>>PBI.pup

// Position to first name block in file
let pos = ns>>NS.firstNamePos  //current displacement in file
SetDirPos(pos)
let disp = lenPup  //current displacement in nameBlock

// Do linear search through name block portion of file
while pos ule ns>>NS.lastNamePos do
   [
   if disp ge lenPup-lenString then
      [
      // Need to refill nameBlock.
      // Move remaining stuff down to beginning of block, then fill
      // remainder of block from file.
      Dismiss(1)
      let remainder = lenPup-disp
      if remainder gr 0 then
         MoveBlock(nameBlock, nameBlock+disp, remainder)
      ReadBlock(ns>>NS.stream, nameBlock+remainder, disp)
      disp = 0
      ]

   // Get pointer to current name block and advance disp to next.
   // Know that name blocks are contiguous and a multiple of 2 words long.
   let name = nameBlock + disp
   let inc = (lenNameHeader + name>>Name.string.length rshift 1 +2) & -2
   disp = disp + inc
   pos = pos + inc

   // Compare key with string in name block
   if key>>String.length ne name>>Name.string.length loop
   if valof
      [
      for i = 1 to key>>String.length do
         [
         let keyChar = key>>String.char↑i
         let dirChar = name>>Name.string.char↑i
         if dirChar ge $a & dirChar le $z then dirChar = dirChar - ($a-$A)
         if keyChar ne dirChar resultis false
         ]
      resultis true
      ] resultis name
   ]

// Not found, return failure.
resultis 0
]