// IfsMailSort.bcpl -- Sorts newly arrived mail
// Copyright Xerox Corporation 1979, 1980, 1981
// Last modified November 18, 1981  9:31 AM by Taft

get "Ifs.decl"
get "IfsDirs.decl"
get "IfsMail.decl"
get "IfsFiles.decl"

external
[
// outgoing procedure
SortNewMail

// incoming procedures from IFS Dirs
DestroyFD; IFSOpenFile; OpenIFSStream
GetBufferForFD; LockTransferLeaderPage

// incoming procedures from disk streams
WriteBlock; Closes; Puts
FilePos; SetFilePos; FileLength

// incoming procedures from other mail modules
EnumerateMailFile; EnumerateMB; ReadMB; WriteMNB
CheckName; MailStatDelay; DiskToDisk

// incoming procedures -- miscellaneous
SysAllocateZero; SysFree; Zero; MoveBlock; Usc
DoubleSubtract; DoubleIncrement; MultEq
IFSError; Dequeue; ReadCalendar
ConcatenateStrings; StringCompare; ExtractSubstring
SetTimer; TimerHasExpired; Dismiss
LockCell; UnlockCell; VFileReadPage

// incoming statics
mail
]


//----------------------------------------------------------------------------
let SortNewMail(stream) = EnumerateMailFile(stream, Sort)
//----------------------------------------------------------------------------

//----------------------------------------------------------------------------
and Sort(msg) be
//----------------------------------------------------------------------------
[
DoubleIncrement(lv mail>>Mail.msgID)  //for duplicate suppression

// Deliver copies to local mailboxes, and build a list of remote servers
EnumerateMB(msg, DeliverLocal)

// Queue copies for forwarding to remote mailboxes
   [
   let hqi = Dequeue(lv msg>>Msg.hostQ); if hqi eq 0 break
   if hqi>>HQI.used then DeliverRemote(msg, hqi)
   SysFree(hqi)
   ] repeat
]

//----------------------------------------------------------------------------
and DeliverLocal(mb, msg) = valof
//----------------------------------------------------------------------------
// Called from EnumerateMB in Sort.
// If mb describes a local mailbox, then append a copy of msg to it.
// If mb describes a remote mailbox, skip it.
// If mb's syntax is bad or it references a nonexistant local mailbox,
//  then change mb into an exception block.
[
if mb>>MB.type ne mbTypeMlbx resultis false

let fd = CheckName(lv mb>>MNB.name, msg, lv mb>>MNB.ec, true)
if fd eq 0 then [ mb>>MNB.type = mbTypeExcp; resultis true ]  //bad syntax
if fd eq -1 then
   [  // Non-local and can forward.
   // Reset MNB.ec in case local mailbox just became non-local.
   if mb>>MNB.ec ne 0 then [ mb>>MNB.ec = 0; resultis true ]
   resultis false
   ]

// Mailbox is local, check for duplicates
let ild = GetBufferForFD(fd)
if LockTransferLeaderPage(fd, ild) eq 0 then  // read
   [
   let fProp = ild + ild>>LD.propertyBegin
   until fProp>>FPROP.type eq 0 % fProp>>FPROP.type eq fPropTypeMsgID do
      fProp = fProp + fProp>>FPROP.length
   if ild+ild>>LD.propertyBegin+ild>>LD.propertyLength uls
    fProp+lenFPropMsgID then IFSError(ecLeaderProps, ild)
   if fProp>>FPROP.type eq 0 then
      [
      fProp>>FPROP.type = fPropTypeMsgID
      fProp>>FPROP.length = lenFPropMsgID
      Zero(lv fProp>>FPropMsgID.msgID, 2)
      fProp!lenFPropMsgID = 0
      ]
   if MultEq(lv fProp>>FPropMsgID.msgID, lv mail>>Mail.msgID) then
      [ // duplicate
      SysFree(ild)
      DestroyFD(fd)
      mb>>MNB.type = mbTypeFree
      resultis true
      ]
   MoveBlock(lv fProp>>FPropMsgID.msgID, lv mail>>Mail.msgID, 2)
   LockTransferLeaderPage(fd, ild, true)  // write
   ]
SysFree(ild)

// try to open a stream on it
let stream, ec = nil, nil
let timer = nil; SetTimer(lv timer, openTimeout*100)
   [
   stream = OpenIFSStream(fd, lv ec, modeAppend)
   if stream ne 0 % ec ne ecFileBusy % TimerHasExpired(lv timer) break
   Dismiss(100)
   ] repeat
if stream eq 0 then
   [  // Busy, try again later
   DestroyFD(fd)
   mb>>MNB.ec = ecFileBusy  // so RemoteRecipients will skip over it
   resultis true
   ]

// append a copy of the message to it
FinishAppendingMsg(StartAppendingMsg(stream), msg)
mb>>MNB.type = mbTypeFree
resultis true
]

//----------------------------------------------------------------------------
and DeliverRemote(inMsg, hqi, outMsg) be
//----------------------------------------------------------------------------
// Generates a message for forwarding to host.  Specifically, it:
//   copies the sender from inMsg;
//   copies recipients whose registry matches hqi;
//   copies the text of inMsg.
// Caller is responsible for ensuring that there is at least one recipient
// for the specified host.
// Note: if hqi is the HQI corresponding to gvName, ALL remote recipients
// are forwarded to this host.  In this case, all the other HQIs will
// not have had their HQI.used bits set, so the HQI for gvName is the
// only one on which DeliverRemote will be called.
// outMsg isn't really an argument, just a local.  Its up there so
//  the compiler will allocate it after 'hqi', which is convenient
//  when calling RemoteRecipients via EnumerateMB, below.
[
// try to open a forwarding file
let fileName = ConcatenateStrings("<Mail>Fwd>", lv hqi>>HQI.name)
let outStream = IFSOpenFile(fileName, 0, modeAppend)
SysFree(fileName)
if outStream eq 0 return

// append to forwarding file
outMsg = StartAppendingMsg(outStream)

// generate the sender
SetFilePos(inMsg>>Msg.stream, lv inMsg>>Msg.posSndr)
let mb = ReadMB(inMsg)
WriteMNB(outMsg, mbTypeSndr, lv mb>>MNB.name)
SysFree(mb)

// generate the list of recipients
EnumerateMB(inMsg, RemoteRecipients, lv hqi)

// Copy message text, close outMsg.
FinishAppendingMsg(outMsg, inMsg)
// don't set Mail.workToDo since the forwarder will run next anyway
]

//----------------------------------------------------------------------------
and RemoteRecipients(mb, inMsg, args) = valof
//----------------------------------------------------------------------------
// Called from EnumerateMB in DeliverRemote.
// Copies mailbox blocks from inMsg to outMsg.
// Marks the mailbox blocks in inMsg free.
// args!0 -> hqi, args!1 -> outMsg
[
let hqi, outMsg = args!0, args!1
if mb>>MNB.type ne mbTypeMlbx % mb>>MNB.ec ne 0 resultis false

// Append entry if hqi corresponds to gvName or registry matches hqi.name.
if hqi ne inMsg>>Msg.gvHQI then
   [
   let name, dot = lv mb>>MNB.name, 0
   for i = name>>String.length to 1 by -1 do
      if name>>String.char↑i eq $. then [ dot = i; break ]
   if StringCompare(name, lv hqi>>HQI.name, dot+1) ne 0 resultis false
   ]

WriteMNB(outMsg, mbTypeMlbx, lv mb>>MNB.name)
mb>>MNB.type = mbTypeFree
resultis true
]

// These two procedures perform the mechanical aspects of appending
//  new messages to message files.  They are used by:
//   DeliverLocal on local mail boxes, and by
//   DeliverRemote on forward files for remote mail systems.

//----------------------------------------------------------------------------
and StartAppendingMsg(outStream) = valof
//----------------------------------------------------------------------------
// Creates and returns an Msg for appending to outStream.
[
let outMsg = SysAllocateZero(lenMsg)
outMsg>>Msg.stream = outStream
FilePos(outStream, lv outMsg>>Msg.posBegin)
WriteBlock(outStream, lv outMsg>>Msg.mh, lenMH)
FilePos(outStream, lv outMsg>>Msg.posBlk)
FilePos(outStream, lv outMsg>>Msg.posTxt)
resultis outMsg
]

//----------------------------------------------------------------------------
and FinishAppendingMsg(outMsg, inMsg) = valof
//----------------------------------------------------------------------------
// Finishes appending inMsg to outMsg -- copies the text, finishes the
//  header, closes the stream, and destroys outMsg.
[
let outStream = outMsg>>Msg.stream
let inStream = inMsg>>Msg.stream
SetFilePos(inStream, lv inMsg>>Msg.posTxt)
MoveBlock(lv outMsg>>Msg.lenTxt, lv inMsg>>Msg.lenTxt, 2)
DiskToDisk(outStream, inStream, lv outMsg>>Msg.lenTxt)
MoveBlock(lv outMsg>>Msg.lenTxt, lv inMsg>>Msg.lenTxt, 2)
if (FilePos(outStream, lv outMsg>>Msg.posEnd) & 1) eq 1 then
   [
   Puts(outStream, 0)  //pad to word boundary
   DoubleIncrement(lv outMsg>>Msg.posEnd)
   ]
ReadCalendar(lv outMsg>>Msg.date)
SetFilePos(outStream, lv outMsg>>Msg.posBegin)
outMsg>>Msg.version = mhVersion
outMsg>>Msg.seal = mhSeal
WriteBlock(outStream, lv outMsg>>Msg.mh, lenMH)
FileLength(outStream)  //so Closes doesn't truncate
Closes(outStream)

// time in seconds msg waited in <Mail>New>Mail
MailStatDelay(msTypeSort, lv inMsg>>Msg.date)

SysFree(outMsg)
resultis 0
]