// IfsMailStore.bcpl -- IFS Mail Server Store command
// Copyright Xerox Corporation 1979, 1980, 1981
// Last modified November 17, 1981  9:05 PM by Taft

get "IfsDirs.decl"
get "IfsFtpProt.decl"
get "IfsMail.decl"
get "IfsSystemInfo.decl"

external
[
// outgoing procedures
MtpSStore; MtpSStoreMail; MtpSStoreCleanup

// incoming procedures from other FTP and Mail modules
FtpSSendMark; NetToDisk; FlipCursor; FTPM
StartMsg; WriteMNB; FinishMsg; CheckName; EnumerateMB

// incoming procedures from IFS Dirs modules
DestroyFD

// incoming procedures - miscellaneous
SysFree; Zero; MultEq; Dequeue; FilePos
LookupErrorCode

// incoming statics
CtxRunning
]

//----------------------------------------------------------------------------
let MtpSStore(pl) = valof
//----------------------------------------------------------------------------
// This procedure is called once for each property list (i.e. each recipient),
//  and then once more (when the [EOC] arrives) with pl = zero.
// The recipients are validated as they arrive; rejected ones are so marked.
// On the last call (when pl = zero), run down the list generating
//  exceptions and checking for a sender and at least one recipient.
[
if CtxRunning>>FtpCtx.msg eq 0 then  //first pl
   [
   let ec = nil
   CtxRunning>>FtpCtx.msg = StartMsg(0, 0, lv ec)
   if CtxRunning>>FtpCtx.msg eq 0 then
      resultis FtpSSendMark(markNo, ec)
   ]
let msg = CtxRunning>>FtpCtx.msg

if pl eq 0 then  //no more pls
   [
   // generate mailbox exceptions
   // we are counting on the way the compiler allocates local variables.
   let sawMlbx, mlbxIndex, sndrEc = false, 1, ecSndrRequired
   EnumerateMB(msg, StoreRecipients, lv sawMlbx)
   while msg>>Msg.hostQ.head ne 0 do
      SysFree(Dequeue(lv msg>>Msg.hostQ))
   // there must be at least one valid MLBX property
   unless sawMlbx resultis FtpSSendMark(markNo, ecNoValidMlbx)
   // check sender property
   if sndrEc eq 0 resultis true
   let errRec = LookupErrorCode(sndrEc)
   FTPM(markNo, 42b, lv errRec>>ErrRec.errorString)
   SysFree(errRec)
   resultis false
   ]

// is there a valid MailBox property?
// Note: must check this first so that MSG.hostQ will be empty
// on first call with lookupMailbox=true
if pl>>PL.MLBX ne 0 then
   [
   let mlbx, ec = pl>>PL.MLBX, 0
   let fd = CheckName(mlbx, msg, lv ec, true)
   if fd ne 0 & fd ne -1 then DestroyFD(fd)
   WriteMNB(msg, (ec eq 0? mbTypeMlbx, mbTypeExcp), mlbx, ec)
   ]

// is there a valid Sender property?
if pl>>PL.SNDR ne 0 & MultEq(lv msg>>Msg.posSndr, table [ 0; 0 ]) then
   [
   let sndr, ec = pl>>PL.SNDR, 0
   CheckName(sndr, msg, lv ec, false)
   WriteMNB(msg, mbTypeSndr, sndr, ec)
   ]

resultis true
]

//----------------------------------------------------------------------------
and MtpSStoreMail() = valof
//----------------------------------------------------------------------------
[
let msg = CtxRunning>>FtpCtx.msg
let ec = NetToDisk(msg>>Msg.stream, CtxRunning>>FtpCtx.bspStream)
if ec eq 0 then
   [
   // disallow zero length messages
   let pos = vec 1; FilePos(msg>>Msg.stream, pos)
   if MultEq(lv msg>>Msg.posTxt, pos) then ec = ecZeroLengthMsg
   ]
resultis ec? FtpSSendMark(markNo, ec), true
]

//----------------------------------------------------------------------------
and MtpSStoreCleanup(ok) be
//----------------------------------------------------------------------------
   if CtxRunning>>FtpCtx.msg then
      CtxRunning>>FtpCtx.msg = FinishMsg(CtxRunning>>FtpCtx.msg, ok)

//----------------------------------------------------------------------------
and StoreRecipients(mb, msg, args) = valof
//----------------------------------------------------------------------------
// Called from EnumerateMB in MtpSStore, this procedure generates mailbox
//  exceptions for those recipients which can be verified on the fly.
// It also sets flags to record seeing at least one recipient.
// args!0 is sawMlbx, args!1 is mlbxIndex, args!2 is sndrEc
[
let rewrite = false
switchon mb>>MB.type into
   [
   case mbTypeMlbx:
      [
      args!0 = true  //sawMlbx
      args!1 = args!1 +1  //mlbxIndex
      endcase
      ]
   case mbTypeExcp:
      [
      let errRec = LookupErrorCode(mb>>MNB.ec)
      FTPM(markMailboxException, errRec>>ErrRec.ftpEc, "$D $S",
        false, args!1, lv errRec>>ErrRec.errorString)
      SysFree(errRec)
      mb>>MNB.type = mbTypeFree
      rewrite = true
      args!1 = args!1 +1  //mlbxIndex
      endcase
      ]
   case mbTypeSndr:
      [
      args!2 = mb>>MNB.ec  // sndrEc
      endcase
      ]
   ]
resultis rewrite
]