// IfsMailForward.bcpl -- Forwards mail to other mail systems
// Copyright Xerox Corporation 1979, 1980, 1981, 1982
// Last modified September 18, 1983  1:41 PM by Taft

get "IfsDirs.decl"
get "IfsFiles.decl"
get "IfsMail.decl"
get "IfsFtpProt.decl"
get lenPort from "Pup0.decl"
get "IfsName.decl"

external
[
// outgoing procedure
ForwardMail

// incoming procedures from Pup package
OpenLevel1Socket; CloseLevel1Socket
OpenRTPSocket; CloseRTPSocket
CreateBSPStream

// incoming procedures from Ftp package
UserOpen; UserClose; UserStoreMail
InitPList; FreePList; FlipCursor; DiskToNet; FtpSSendMark

// incoming procedures from other mail modules
EnumerateMailFile; EnumerateMB; ReadMB; MailStatDelay
StartUndelivMsg; FinishMsg

// incoming procedures from Streams package
FilePos; SetFilePos; WriteBlock

// incoming procedures -- miscellaneous
IFSError; EnumeratePupAddresses; IFSPrintError; StreamsFD
SysAllocate; SysFree; FreePointer; Zero; MoveBlock; Noop
DoubleUsc; DeclarePupSoc
ExtractSubstring; PutTemplate

// incoming statics
CtxRunning; debugFlag
dFTPI; lBSPSoc; mail
]

//----------------------------------------------------------------------------
let ForwardMail(stream) = valof
//----------------------------------------------------------------------------
// stream is open on a file containing messages queued for delivery to a
//  remote host.  ForwardMail tries to open an MTP connection to the host
//  and send the mail.  Returns true if the file behind stream can be deleted.
// stream is enumerated even if forwarding is disabled so that
//  delivery timeouts can be detected.
[
let soc = 0
if mail>>Mail.forward ne 0 then
   [
   // extract registry name from file name
   let fd = StreamsFD(stream)
   let host = ExtractSubstring(lv fd>>FD.dr>>DR.pathName,
    fd>>FD.lenSubDirString+1, fd>>FD.lenBodyString-1)

   // for registries that map to multiple addresses, try each one in order
   // of distance from here.
   EnumeratePupAddresses(host, FwdOpenConn)
   SysFree(host)
   soc = CtxRunning>>FtpCtx.bspSoc
   if soc ne 0 then
      [
      CtxRunning>>FtpCtx.bspStream = CreateBSPStream(soc)
      CtxRunning>>FtpCtx.dspStream = dFTPI>>FTPI.dspStream
      CtxRunning>>FtpCtx.lst = dFTPI>>FTPI.lst
      CtxRunning>>FtpCtx.dls = dFTPI>>FTPI.dls
      CtxRunning>>FtpCtx.dbls = CtxRunning>>FtpCtx.bspStream
      UserOpen(Noop)
      ]
   ]

// do the work
let delete = EnumerateMailFile(stream, Forward)

// Clean up network stuff
if soc ne 0 then
   [
   if CtxRunning>>FtpCtx.connFlag then UserClose(false)
   DeclarePupSoc(0)
   SysFree(soc)
   ]

resultis delete
]

//----------------------------------------------------------------------------
and FwdOpenConn(port, nil) = valof
//----------------------------------------------------------------------------
// Proc passed to EnumeratePupAddresses -- attempts to connect to each
// port until one succeeds.
[
let soc = SysAllocate(lBSPSoc)
OpenLevel1Socket(soc, 0, port)
DeclarePupSoc(soc)  // puts soc in CtxRunning>>FtpCtx.bspSoc
if OpenRTPSocket(soc) resultis true  // succeeded, stop enumeration

// failed, clean up and continue
CloseLevel1Socket(soc)
DeclarePupSoc(0)
SysFree(soc)
resultis false
]

//----------------------------------------------------------------------------
and Forward(msg) be
//----------------------------------------------------------------------------
// Called from EnumerateMailFile in ForwardMail.
// Calls the MTP module to send messages to remote sites.
[
if CtxRunning>>FtpCtx.connFlag then
   [
   CtxRunning>>FtpCtx.msg = msg
   let mark = UserStoreMail(FwdGen, FwdExcp, FwdXfer)
   if mark eq 0 then
      [  // MTP catastrophe - undo everything
      if CtxRunning>>FtpCtx.connFlag then UserClose(true)
      if msg>>Msg.uMsg then
         msg>>Msg.uMsg = FinishMsg(msg>>Msg.uMsg, 0)
      ]
   EnumerateMB(msg, FwdFree, mark)
   if mark<<Mark.mark eq markYes then
      MailStatDelay(msTypeFwd, lv msg>>Msg.date)
   ]
]

//----------------------------------------------------------------------------
and FwdGen(pl) = valof
//----------------------------------------------------------------------------
// Called from UserStoreMail, generates the next recipient pl.
// The sender is included in the first pl only.
[
let msg = CtxRunning>>FtpCtx.msg
let stream = msg>>Msg.stream

let mb, sndr, mlbx = SysAllocate(maxLenMB), 0, 0
if pl eq 0 then  //first time -- generate Sndr property
   [
   SetFilePos(stream, lv msg>>Msg.posSndr)
   ReadMB(msg, mb)
   sndr = ExtractSubstring(lv mb>>MNB.name)
   SetFilePos(stream, lv msg>>Msg.posBlk)
   ]

   [  //generate next Mlbx
   let pos = vec 1; FilePos(stream, pos)
   if DoubleUsc(pos, lv msg>>Msg.posTxt) ge 0 break
   ReadMB(msg, mb)
   if mb>>MB.type ne mbTypeMlbx loop
   mlbx = ExtractSubstring(lv mb>>MNB.name)
   break
   ] repeat
SysFree(mb)

pl = FreePList(pl)
test mlbx eq 0
   ifso if sndr ne 0 then SysFree(sndr)
   ifnot
      [
      pl = InitPList()
      pl>>PL.SNDR = sndr
      pl>>PL.MLBX = mlbx
      ]

resultis pl
]

//----------------------------------------------------------------------------
and FwdExcp(mark, index) be
//----------------------------------------------------------------------------
// Called from UserStoreMail to announce rejection of mailbox 'index'.
// It finds the mailbox block, marks it free, and copies the rejection
//  text from the remote server into an undeliverable msg msg.
// If it can't create an undeliverable msg msg, then it changes the
//  mailbox block into an exception, in the hope that later on it
//  will be able to create one.
[
let msg = CtxRunning>>FtpCtx.msg
let diskStream = msg>>Msg.stream

// if we don't have an undeliverable message set up, do so
if msg>>Msg.uMsg eq 0 then
   [
   StartUndelivMsg(msg)
   CtxRunning>>FtpCtx.index = 77777b
   ]

// do we have to back up and scan forward?
if CtxRunning>>FtpCtx.index gr index then
   [
   SetFilePos(diskStream, lv msg>>Msg.posBlk)
   CtxRunning>>FtpCtx.index = 0
   ]

// find the offending mailbox block
let mb, pos = SysAllocate(maxLenMB), vec 1
   [
   FilePos(diskStream, pos)
   if DoubleUsc(pos, lv msg>>Msg.posTxt) ge 0 then
      [  //index supplied by remote server is bogus
      if debugFlag then IFSError(ecMlbxIndex, index, msg)
      CtxRunning>>FtpCtx.index = 77777b  //force a backup
      SysFree(mb)
      return
      ]
   ReadMB(msg, mb)
   if mb>>MB.type ne mbTypeMlbx & mb>>MB.type ne mbTypeTempFree &
    mb>>MB.type ne mbTypeTempExcp loop
   CtxRunning>>FtpCtx.index = CtxRunning>>FtpCtx.index +1
   if CtxRunning>>FtpCtx.index eq index break
   ] repeat

// generate the mailbox name and error text
test msg>>Msg.uMsg ne 0
   ifso
      [
      PutTemplate(msg>>Msg.uMsg>>Msg.stream, "*N$S - $S",
       lv mb>>MNB.name, CtxRunning>>FtpCtx.getCmdString)
      mb>>MB.type = mbTypeTempFree
      ]
   ifnot
      [
      mb>>MNB.ec = ecUnspecified
      mb>>MB.type = mbTypeTempExcp
      ]

SetFilePos(diskStream, pos)
WriteBlock(diskStream, mb, mb>>MB.length)
SysFree(mb)
]

//----------------------------------------------------------------------------
and FwdXfer() = valof
//----------------------------------------------------------------------------
// Moves the message text over the connection.
[
let msg = CtxRunning>>FtpCtx.msg
let diskStream = msg>>Msg.stream
let bytes = vec 1; MoveBlock(bytes, lv msg>>Msg.lenTxt, 2)
SetFilePos(diskStream, lv msg>>Msg.posTxt)
let ec = DiskToNet(CtxRunning>>FtpCtx.bspStream, diskStream, bytes)
resultis ec? FtpSSendMark(markNo, ec), true
]

//----------------------------------------------------------------------------
and FwdFree(mb, msg, mark) = valof
//----------------------------------------------------------------------------
// Called from EnumerateMB in ForwardMail.
// Cleans up after attempting to forward a message.
[
let code = mark<<Mark.subCode
mark = mark<<Mark.mark
let type = mb>>MB.type

if type eq mbTypeMlbx & mark eq markNo &
 ((code ge 40b & code le 43b) % code eq 110b) then
   [  // permanent error -- return to sender
   if msg>>Msg.uMsg eq 0 then StartUndelivMsg(msg)
   test msg>>Msg.uMsg ne 0
      ifso
         [
         PutTemplate(msg>>Msg.uMsg>>Msg.stream, "*N$S - $S",
          lv mb>>MNB.name, CtxRunning>>FtpCtx.getCmdString)
         mb>>MB.type = mbTypeFree
         ]
      ifnot
         [
         mb>>MB.type = mbTypeExcp
         mb>>MNB.ec = ecUnspecified
         ]
   resultis true
   ]

if type eq mbTypeMlbx & mark eq markYes then
   mb>>MB.type = mbTypeFree
if type eq mbTypeTempFree then
   mb>>MB.type = mark eq 0? mbTypeMlbx, mbTypeFree
if type eq mbTypeTempExcp then
   mb>>MB.type = mark eq 0? mbTypeMlbx, mbTypeExcp

resultis type ne mb>>MB.type
]