// IfsMailJob.bcpl -- sorts and forwards mail
// Copyright Xerox Corporation 1979, 1980, 1981, 1982
// Last modified April 9, 1982  12:33 PM by Taft

get "Ifs.decl"
get "IfsMail.decl"
get "IfsDirs.decl"
get "IfsFtpProt.decl"
get "AltoFileSys.d"

external
[
// outgoing procedures
MailJob; EnumerateMailFile; EnumerateMB; ReadMB

// incoming procedures from other mail modules
SortNewMail; ForwardMail; StartUndelivMsg; FinishUndelivMsg

// incoming procedures from IFS dirs
LookupIFSFile; NextFD; DestroyFD; DeleteFileFromFD; GetBufferForFD
LockTransferLeaderPage; OpenIFSStream; CloseIFSStream; CloseIFSFile

// incoming procedures - misc
DestroyJob; JobOK; IFSError; IFSPrintError
ReadBlock; WriteBlock; Closes; Endofs; FilePos; SetFilePos
DoubleIncrement; DoubleUsc; DoubleAdd; Mul
SysAllocate; SysFree; ReadCalendar; Zero; PutTemplate

// incoming statics
mail; debugFlag
]

//---------------------------------------------------------------------------
let MailJob(ctx) be	// a context
//---------------------------------------------------------------------------
[
ctx>>RSCtx.userInfo = mail>>Mail.ui

   [ // repeat
   mail>>Mail.workToDo = false
   EnumerateMailDir("<Mail>New>Mail!**", SortNewMail, minSortInterval)
   EnumerateMailDir("<Mail>Fwd>**!1", ForwardMail, minForwardInterval)
   ] repeatwhile mail>>Mail.enabled ne 0 & mail>>Mail.workToDo ne 0 &
      JobOK(jobTypeMail)

mail>>Mail.wake = jobInterval/eventInterval
mail>>Mail.ctx = 0
DestroyJob()
]

//----------------------------------------------------------------------------
and EnumerateMailDir(dirName, Proc, minInterval) be
//----------------------------------------------------------------------------
// Enumerates all files matching dirName, opens a stream and calls Proc.
// Skips over a file if it was last checked less than minInterval seconds ago,
// unless it has been written more recently than that.
// If Proc returns true, the file is then deleted.
[
let fd = LookupIFSFile(dirName, lcMultiple)
if fd eq 0 return

   [ // repeat
   // Continue or stop?
   if mail>>Mail.enabled eq 0 break
   unless JobOK(jobTypeMail) do [ mail>>Mail.workToDo = true; break ]

   // We should look closely at this file if it has been written since
   // last read or if it hasn't been read for at least minInterval.
   let time = vec 1; ReadCalendar(time)
   DoubleIncrement(time, -minInterval)
   let ld = GetBufferForFD(fd)
   let ok = LockTransferLeaderPage(fd, ld) eq 0 &
    (DoubleUsc(lv ld>>LD.written, lv ld>>LD.read) gr 0 %
     DoubleUsc(time, lv ld>>LD.read) ge 0)
   SysFree(ld)
   unless ok loop

   // Open the file and see what's inside.
   let stream = OpenIFSStream(fd, 0, modeReadWrite)
   if stream ne 0 then
      [
      let delete = Proc(stream)
      // Do not unlock file if we're going to delete it.
      CloseIFSStream(stream, delete)
      if delete then
         if DeleteFileFromFD(fd, false, true) ne 0 then CloseIFSFile(fd)
      ]
   ] repeatwhile NextFD(fd)

// Done enumeration -- cleanup and go away
DestroyFD(fd)
]

//----------------------------------------------------------------------------
and EnumerateMailFile(stream, Proc) = valof
//----------------------------------------------------------------------------
// Enumerates all msgs in the stream, calling Proc for each one.
// Returns true if the file behind stream can be deleted.
[
let delete = true
let msg = vec lenMsg; Zero(msg, lenMsg)
msg>>Msg.stream = stream

   [  // read next message in file
   SetFilePos(stream, lv msg>>Msg.posEnd)
   if Endofs(stream) break

   // if the message is damaged, skip it.
   if ReadBlock(stream, lv msg>>Msg.mh, lenMH) ne lenMH then
      [ if debugFlag then IFSError(ecEofInHdr, msg); break ]
   if msg>>Msg.seal ne mhSeal then
      [ if debugFlag then IFSError(ecBadMsgSeal, msg); break ]
   if msg>>Msg.numActive eq 0 loop

   Proc(msg)

   // Check long-term timeout and handle any Exception blocks.
   let timeout = vec 1; Mul(0, 3600, deliveryTimeout, timeout)
   DoubleAdd(timeout, lv msg>>Msg.date)
   let now = vec 1; ReadCalendar(now)
   EnumerateMB(msg, Undeliv, DoubleUsc(now, timeout) ge 0)

   // if there is one, finish off the undeliverable msg msg
   if msg>>Msg.uMsg then FinishUndelivMsg(msg)

   // rewrite message header
   if msg>>Msg.numActive ne 0 then delete = false
   SetFilePos(stream, lv msg>>Msg.posBegin)
   WriteBlock(stream, lv msg>>Msg.mh, lenMH)
   ] repeat

resultis delete
]

//----------------------------------------------------------------------------
and Undeliv(mb, msg, timeout) = valof
//----------------------------------------------------------------------------
// Called from EnumeratMB in EnumerateMailFile.
// If 'timeout' then converts all active blocks into exception blocks.
// Generates an undeliverable message message for all exception blocks.
[
let rewrite, type = false, mb>>MB.type
if timeout & type ne mbTypeFree & type ne mbTypeSndr & type ne mbTypeExcp then
   [
   mb>>MB.type = mbTypeExcp
   mb>>MNB.ec = ecDeliveryTimeout
   rewrite = true
   ]
if mb>>MB.type ne mbTypeExcp resultis false

if msg>>Msg.uMsg eq 0 then StartUndelivMsg(msg)
if msg>>Msg.uMsg ne 0 then
   [
   let uStream = msg>>Msg.uMsg>>Msg.stream
   PutTemplate(uStream, "*N$S - ", lv mb>>MNB.name)
   IFSPrintError(uStream, mb>>MNB.ec)
   mb>>MB.type = mbTypeFree
   rewrite = true
   ]

resultis rewrite
]

//----------------------------------------------------------------------------
and EnumerateMB(msg, Proc, arg) be
//----------------------------------------------------------------------------
// Enumerates the Blocks in msg calling Proc for each one.
// If Proc returns true, the block is rewritten.
// Changing the length of the block is forbidden.
[
let stream = msg>>Msg.stream
SetFilePos(stream, lv msg>>Msg.posBlk)
msg>>Msg.numActive = 0
let mb = SysAllocate(maxLenMB)

   [
   let thisPos = vec 1; FilePos(stream, thisPos)
   if DoubleUsc(thisPos, lv msg>>Msg.posTxt) ge 0 break
   ReadMB(msg, mb)
   let nextPos = vec 1; FilePos(stream, nextPos)
   test Proc(mb, msg, arg)  //rewrite block?
      ifnot SetFilePos(stream, nextPos)  //Proc may have changed stream pos.
      ifso  //back up and rewrite the block
         [
         SetFilePos(stream, thisPos)
         WriteBlock(stream, mb, mb>>MB.length)
         ]
   unless mb>>MB.type eq mbTypeFree % mb>>MB.type eq mbTypeSndr do
      msg>>Msg.numActive = msg>>Msg.numActive +1
   ] repeat

SysFree(mb)
]

//----------------------------------------------------------------------------
and ReadMB(msg, mb; numargs na) = valof
//----------------------------------------------------------------------------
[
let temp = nil
ReadBlock(msg>>Msg.stream, lv temp, 1)
if na ls 2 % mb eq 0 then mb = SysAllocate(temp<<MB.length)
mb!0 = temp
if ReadBlock(msg>>Msg.stream, mb+1, mb>>MB.length-1) ne mb>>MB.length-1 then
   IFSError(ecEofInBlk, msg)
resultis mb
]