-- file: FTPServerMail.mesa
-- Edited by Mark Johnson:  19-May-81 13:24:24
-- Edited by Andrew Birrell: 18-Jan-82 10:25:37
-- Edited by: HGM March 6, 1979  4:05 PM  
-- Edited by: JEW October 31, 1978  3:28 PM

DIRECTORY
  BodyDefs	USING[ maxRNameLength ],
  FTPDefs:		FROM "FTPDefs",
  FTPPrivateDefs:	FROM "FTPPrivateDefs",
  SendDefs	USING[ AddRecipient, AddToItem, Create, Destroy,
		       CheckValidity, Handle, Send, SendFromClient,
		       StartSendInfo, StartText ],
  String	USING [AppendChar, AppendDecimal, AppendLongNumber],
  Storage	USING [Node, Free, FreeString];

FTPServerMail: PROGRAM
  -- import list
    IMPORTS SendDefs, String, Storage, FTPDefs, FTPPrivateDefs
  -- export list
    EXPORTS FTPPrivateDefs
  -- share list
    SHARES FTPDefs, FTPPrivateDefs
  = BEGIN OPEN FTPDefs, FTPPrivateDefs;

-- **********************!  Constants  !***********************

ftpsystem: POINTER TO FTPSystem = LocateFtpSystemObject[];
 
-- **********************!  Module Presence Test Procedure  !***********************

ServerMailLoaded: PUBLIC PROCEDURE =
  BEGIN
  -- report in
    ftpsystem.serverMailLoaded _ TRUE;
  END;
 
-- **********************!  Mail Commands  !***********************

PTFStoreMail: PUBLIC PROCEDURE [ftpserver: FTPServer] =
  BEGIN OPEN ftpserver, ftpserver.ftplistener;
  -- PutMailboxException procedure
    sender: STRING;
    PutMailboxException: PROCEDURE [number: CARDINAL, recipientError: RecipientError] =
      BEGIN
      -- local constants
        message: STRING = [maxStringLength];
      -- construct error message
        String.AppendDecimal[message, number];
        String.AppendChar[message, mailboxExceptionIndexTerminator];
        IF ftpsystem.accessoriesLoaded THEN VerbalizeRecipientError[recipientError, message];
      -- send mailbox exception command
        PutCommand[ftper, markMailboxException,
          RecipientErrorToExceptionCode[recipientError]];
      -- send error message
        PutString[ftper, message];
      END;
    EarlyAbort: PROC[why: SendDefs.StartSendInfo] =
      BEGIN
      DO GetPropertyList[ftper, propertyList ! FTPError =>
            IF ftpError = protocolParameterListMissing THEN EXIT];
      ENDLOOP;
      SELECT why FROM
        badPwd =>
          AbortWithExplanation[unidentifiedPermanentError,
                               "Incorrect sender password"L];
        badSender, badReturnTo =>
          AbortWithExplanation[unidentifiedPermanentError,
            SELECT TRUE FROM
              sender = NIL => "Sender name missing"L,
              sender.length > BodyDefs.maxRNameLength =>
                "Sender name too long"L,
            ENDCASE => "Sender name not valid"L];
      ENDCASE => ERROR -- allDown, ok --;
    END;
  -- local variables
    gvHandle: SendDefs.Handle = SendDefs.Create[];
  -- intercept errors
    BEGIN ENABLE UNWIND => SendDefs.Destroy[gvHandle];
  -- start message; first property list must have sender --
    recipients: CARDINAL _ 0;

-- BEWARE: assumes representation of MailSystemObject --
    mailInfo: POINTER TO RECORD[ net, host: [0..256)] = LOOPHOLE[mailSystem];
    GetPropertyList[ftper, propertyList]; --must be present--
    sender _ propertyList[sender];
    IF sender = NIL THEN EarlyAbort[badSender];
    IF sender.length > BodyDefs.maxRNameLength THEN EarlyAbort[badSender];
    BEGIN
      sendInfo: SendDefs.StartSendInfo =
           SendDefs.SendFromClient[handle: gvHandle,
                              fromNet:mailInfo.net, fromHost:mailInfo.host,
                              senderKey: [0,0,0,0],
                              sender: sender, returnTo: sender,
                              validate: TRUE];
      IF sendInfo # ok THEN EarlyAbort[sendInfo];
    END;
  -- receive distribution list and EOC
    DO
      -- enqueue for recipient
      SendDefs.AddRecipient[gvHandle, propertyList[mailbox]];
      recipients _ recipients + 1;
      -- receive next property list
      GetPropertyList[ftper, propertyList ! FTPError =>
          IF ftpError = protocolParameterListMissing THEN EXIT];
      ENDLOOP;
    GetEOC[ftper];
  -- reject undefined recipients
    BEGIN
      Notify: PROCEDURE[number: CARDINAL, recipient: STRING] =
         BEGIN
         recipients _ recipients - 1;
         PutMailboxException[number, noSuchMailbox];
         END;
      [] _ SendDefs.CheckValidity[gvHandle, Notify];
    END;
  -- send preliminary approval of distribution list
    IF recipients # 0 THEN PutCommandAndEOC[ftper, markYes, 0]
    ELSE Abort[noValidRecipients];
  -- accept message text
    GetSpecificCommand[ftper, markHereIsFile];
    StageMessage[gvHandle, ReceiveBlock, ftper];
    GetYesAndEOC[ftper];
  -- deliver message
    SendDefs.Send[gvHandle];
  -- send Yes and EOC
    PutCommandAndEOC[ftper, markYes, 0];
  -- tidy up
    SendDefs.Destroy[gvHandle];
    END; -- enable
  END;

PTFRetrieveMail: PUBLIC PROCEDURE [ftpserver: FTPServer] =
  BEGIN OPEN ftpserver, ftpserver.ftplistener;
  -- NextMessage procedure
    NextMessage: PROCEDURE [messageInfo: MessageInfo] =
      BEGIN OPEN messageInfo;
      -- next message
        IF byteCount # 0 THEN
          BEGIN
          -- send message information
            PutCommand[ftper, markHereIsPropertyList, 0];
            PutMessageInfo[messageInfo];
          -- signal transmission of text
            PutCommand[ftper, markHereIsFile, 0];
          END
      -- no more messages
        ELSE
          BEGIN
          -- send Yes and EOC
            PutCommandAndEOC[ftper, markYes, 0];
          -- receive OK to flush mailbox
            GetSpecificCommand[ftper, markFlushMailbox];
            GetEOC[ftper];
          END;
      END;
  -- PutMessageInfo procedure
    PutMessageInfo: PROCEDURE [messageInfo: MessageInfo] =
      BEGIN OPEN messageInfo;
      -- local constants
        messageLength: STRING = [maxStringLength];
        boolean: STRING = [maxStringLength];
      -- reset property list
        ResetPropertyList[propertyList];
      -- encode byte count
        String.AppendLongNumber[messageLength, byteCount, 10];
        WriteProperty[propertyList, length, messageLength];
      -- encode delivery date
        WriteProperty[propertyList, dateReceived, deliveryDate];
      -- encode opened and deleted
        EncodeBooleanProperty[opened, boolean];
        WriteProperty[propertyList, opened, boolean];
        EncodeBooleanProperty[deleted, boolean];
        WriteProperty[propertyList, deleted, boolean];
      -- send property list
        PutPropertyList[ftper, propertyList];
      END;
  -- local variables
    mailbox: Mailbox _ NIL;
  -- receive property list and EOC
    GetPropertyList[ftper, propertyList];  GetEOC[ftper];
  -- inspect credentials
    IF propertyList[userName] # NIL THEN
      mailPrimitives.InspectCredentials[mailSystem, primary,
        propertyList[userName], propertyList[userPassword]];
    IF propertyList[connectName] # NIL THEN
      mailPrimitives.InspectCredentials[mailSystem, secondary,
        propertyList[connectName], propertyList[connectPassword]];
  -- enqueue mailbox
    mailbox _ CreateMailbox[propertyList, 1];
    BEGIN ENABLE UNWIND => DestroyMailbox[mailbox];
  -- locate local mailbox
    mailPrimitives.LocateMailboxes[mailSystem, mailbox];
    IF ~mailbox.located THEN Abort[noSuchMailbox];
  -- retrieve messages
    mailPrimitives.RetrieveMessages[mailSystem, mailbox, NextMessage, SendBlock, ftper];
    PutCommandAndEOC[ftper, markYes, 0];
  -- destroy mailbox
    END; -- enable
    DestroyMailbox[mailbox];
  END;

-- **********************!  Mailbox Primitives  !***********************

StageMessage: PROCEDURE[ gvHandle: SendDefs.Handle,
      receiveBlock: PROCEDURE[UNSPECIFIED,POINTER,CARDINAL]RETURNS[CARDINAL],
      receiveBlockData: UNSPECIFIED ] =
   BEGIN
   length: CARDINAL = 65;
   prevOdd: BOOLEAN _ FALSE;
   buffer: POINTER = Storage.Node[length];
   SendDefs.StartText[gvHandle];
   DO BEGIN
      ENABLE UNWIND => Storage.Free[buffer];
      count: CARDINAL = receiveBlock[receiveBlockData,buffer,length];
      IF count = 0 THEN EXIT;
      IF prevOdd
      THEN ERROR FTPDefs.FTPError[requestedAccessDenied,
                          "Odd-byte block boundary not implemented"L];
      SendDefs.AddToItem[gvHandle, DESCRIPTOR[buffer, count] ];
      IF count MOD 2 # 0 THEN prevOdd _ TRUE;
      END;
   ENDLOOP;
   Storage.Free[buffer];
   END;

CreateMailbox: PROCEDURE [propertyList: PropertyList, number: CARDINAL] RETURNS [mailbox: Mailbox] =
  BEGIN
  -- Note:  Initializes nextMailbox to NIL;
  --   removes mailbox property from property list.
  -- allocate and initialize mailbox object
    mailbox _ Storage.Node[SIZE[MailboxObject]];
    mailbox^ _ MailboxObject[
      number: number,
      mailbox: propertyList[mailbox], location: NIL,
      located: FALSE, delivered: FALSE,
      nextMailbox: NIL];
  -- remove mailbox, host, and dms name from property list
  -- Note: WriteProperty was circumvented above.
    propertyList[mailbox] _ NIL;
  END;

DestroyMailbox: PROCEDURE [mailbox: Mailbox] =
  BEGIN
  -- release mailbox if any
    IF mailbox.mailbox # NIL THEN Storage.FreeString[mailbox.mailbox];
  -- release location if any
    IF mailbox.location # NIL THEN Storage.FreeString[mailbox.location];
  -- release mailbox object
    Storage.Free[mailbox];
  END;

-- **********************!  Main Program  !***********************

-- no operation

END. -- of FTPServerMail