// 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"

// outgoing procedure

// 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

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)
   ] 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
      mb>>MNB.type = mbTypeFree
      resultis true
   MoveBlock(lv fProp>>FPropMsgID.msgID, lv mail>>Mail.msgID, 2)
   LockTransferLeaderPage(fd, ild, true)  // write

// 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
   ] repeat
if stream eq 0 then
   [  // Busy, try again later
   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)
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)

// 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

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

resultis 0