// IfsMailRetrieve.bcpl - IFS Mail Server Retrieve command
// Copyright Xerox Corporation 1979, 1980, 1981, 1982
// Last modified May 13, 1982  2:21 PM by Taft

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

external
[
// outgoing procedures
MtpSRetrieve; MtpSRetrieveMail; MtpSRetrieveCleanup

// incoming procedures from other FTP and Mail modules
FtpSCheckAccess; FtpSSendMark
FlipCursor; DiskToNet; FreePList; InitPList; MailStatDelay

// incoming procedures from IFS Dirs
IFSOpenFile; OpenIFSStream; CloseIFSStream
DestroyFD; DeleteFileFromFD; StreamsFD

// incoming procedures - miscellaneous
SysAllocateZero; SysFree; ExtractSubstring; ConcatenateStrings; RNamesEqual
SetTimer; Dismiss; TimerHasExpired; SetFilePos
Resets; Closes; Endofs; ReadBlock; TruncateDiskStream
MoveBlock; Zero
IFSError

// incoming statics
CtxRunning; mail; debugFlag
]

//----------------------------------------------------------------------------
let MtpSRetrieve(remotePL, localPL) = valof
//----------------------------------------------------------------------------
[
localPL = FreePList(localPL)
if CtxRunning>>FtpCtx.msg eq 0 then  //first time for this Retrieve
   [
   // Check out his pList
   unless FtpSCheckAccess(remotePL) resultis 0
   let mailbox = remotePL>>PL.MLBX
   if mailbox eq 0 resultis FtpSSendMark(markNo, ecMlbxRequired)
   for i = mailbox>>String.length to 1 by -1 do
      if mailbox>>String.char↑i eq $. then
         [ mailbox>>String.length = i-1; break ]
   unless RNamesEqual(mailbox, remotePL>>PL.UNAM) %
    RNamesEqual(mailbox, remotePL>>PL.CNAM) do
      resultis FtpSSendMark(markNo, ecMlbxNotUnamOrCnam)

   // Is there a mailbox?
   // IFSOpenFile checks access, so switch to our "Mail" identity.
   let ui = CtxRunning>>FtpCtx.userInfo
   CtxRunning>>FtpCtx.userInfo = mail>>Mail.ui
   mailbox = ConcatenateStrings("<Mail>Box>", mailbox)
   let ec, stream = 0, 0
   let timer = nil; SetTimer(lv timer, openTimeout*100)
      [ // repeat
      stream = IFSOpenFile(mailbox, lv ec, modeReadWrite, 0, lcVHighest)
      if stream ne 0 % ec ne ecFileBusy % TimerHasExpired(lv timer) break
      Dismiss(100)  // Busy.  Wait 1 second, then try again
      ] repeat
   CtxRunning>>FtpCtx.userInfo = ui  // switch back to user's identity
   SysFree(mailbox)
   if stream eq 0 then
      resultis FtpSSendMark(markNo,
       (ec eq ecFileNotFound % ec eq ecDirNotFound? ecNoMailbox, ec))

   let msg = SysAllocateZero(lenMsg)
   msg>>Msg.stream = stream
   CtxRunning>>FtpCtx.msg = msg
   ]

let msg = CtxRunning>>FtpCtx.msg
SetFilePos(msg>>Msg.stream, lv msg>>Msg.posEnd)
if Endofs(msg>>Msg.stream) resultis -1

// If the next message is damaged, then say 'no more messages',
//  which will case the file to be emptied thereby healing it.
if ReadBlock(msg>>Msg.stream, lv msg>>Msg.mh, lenMH) ne lenMH then
   [ if debugFlag then IFSError(ecEofInHdr, msg); resultis -1 ]
if msg>>Msg.seal ne mhSeal then
   [ if debugFlag then IFSError(ecBadMsgSeal, msg); resultis -1 ]

// Set up the pList for the next message.
localPL = InitPList()
MoveBlock(lv localPL>>PL.LGTH, lv msg>>Msg.lenTxt, 2)
MoveBlock(lv localPL>>PL.RCVD, lv msg>>Msg.date, 2)

// ready to transfer message body
resultis localPL
]

//----------------------------------------------------------------------------
let MtpSRetrieveMail(nil, nil) = valof
//----------------------------------------------------------------------------
[
let msg = CtxRunning>>FtpCtx.msg
let bytes = vec 1; MoveBlock(bytes, lv msg>>Msg.lenTxt, 2)

SetFilePos(msg>>Msg.stream, lv msg>>Msg.posTxt)
let ec = DiskToNet(CtxRunning>>FtpCtx.bspStream, msg>>Msg.stream, bytes)
if ec eq 0 then
   [
   // time in seconds message waited in mailbox
   MailStatDelay(msTypeRetr, lv msg>>Msg.date)
   resultis true
   ]

FtpSSendMark(markNo, ec)
resultis false
]

//----------------------------------------------------------------------------
and MtpSRetrieveCleanup(remotePL, ok) = valof
//----------------------------------------------------------------------------
[
let msg = CtxRunning>>FtpCtx.msg
let stream = msg>>Msg.stream

if ok then
   [  // ok to flush mail from mailbox
   let fd = StreamsFD(stream)
   let ui = CtxRunning>>FtpCtx.userInfo
   let mbxName = ExtractSubstring(lv fd>>FD.dr>>DR.pathName,
     fd>>FD.lenSubDirString+1, fd>>FD.lenBodyString-1)
   test ui>>UserInfo.capabilities.mail eq 0 &
    RNamesEqual(mbxName, ui>>UserInfo.userName)
      ifso
         [  // User no longer has mail capability; destroy mailbox.
         // To avoid a race with another process attempting to store new
         // mail, we exploit the feature of DeleteFileFromFD that permits
         // the caller to pass in the FD for an open file.
         CloseIFSStream(stream, true)  // just destroy stream; FD stays open
         CtxRunning>>FtpCtx.userInfo = mail>>Mail.ui
         unless DeleteFileFromFD(fd, false, true) eq 0 do
            IFSError(ecMlbxDelFailed)
         CtxRunning>>FtpCtx.userInfo = ui
         DestroyFD(fd)
         stream = 0
         ]
      ifnot
         [  // Normal case: make mailbox empty
         Resets(stream)
         TruncateDiskStream(stream)
         ]
   SysFree(mbxName)
   ]

if msg ne 0 then
   [
   if stream ne 0 then Closes(stream)
   SysFree(msg)
   CtxRunning>>FtpCtx.msg = 0
   ]

resultis ok
]