-- FTPSysMail.mesa,  Edit: HGM July 28, 1980  10:32 PM  

-- Copyright  Xerox Corporation 1979, 1980

DIRECTORY
  FTPDefs,
  FTPPrivateDefs,
  Ascii USING [CR],
  Inline USING [LowHalf],
  String USING [AppendChar, AppendLongNumber, EquivalentString, StringToLongNumber],
  Storage USING [Node, Free, CopyString],
  Time USING [AppendCurrent];

FTPSysMail: PROGRAM
    IMPORTS Inline, String, Storage, Time, FTPDefs, FTPPrivateDefs
    EXPORTS FTPDefs
    SHARES FTPDefs, FTPPrivateDefs =
BEGIN OPEN FTPDefs, FTPPrivateDefs; 
 
-- **********************!  Types  !***********************

-- mail system state information
SysMailSystem: TYPE = POINTER TO SysMailSystemObject;
SysMailSystemObject: TYPE = RECORD [
  filePrimitives: FilePrimitives,
  fileSystem: FileSystem,
  directoryFileHandle, stagingFileHandle: FileHandle,
  messageLength: LONG INTEGER];

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

mailboxTerminator:		CHARACTER = '@;
fileTerminator:		CHARACTER = Ascii.CR;
dateAndTimeTerminator:		CHARACTER = ';;
messageLengthTerminator:	CHARACTER = Ascii.CR;

ftpsystem: POINTER TO FTPSystem = LocateFtpSystemObject[];

mailPrimitivesObject: MailPrimitivesObject _ [
  CreateMailSystem: CreateMailSystem,
  DestroyMailSystem: DestroyMailSystem,
  InspectCredentials: InspectCredentials,
  LocateMailboxes: LocateMailboxes,
  StageMessage: StageMessage,
  DeliverMessage: DeliverMessage,
  ForwardMessage: ForwardMessage,
  RetrieveMessages: RetrieveMessages];

-- **********************!  Variables  !***********************

useCount: CARDINAL _ 0;
mailboxQueueObject: QueueObject;

-- **********************!  Mail Foothold Procedure  !***********************

-- Note:  This mail system is constructed atop the client's file system.
--   Besides a scratch file in which the text of incoming messages is staged,
--   and a semi-permanent mailbox file for each legal mail recipient,
--   the following prefabricated, permanent file giving mailbox->filename correspondences
--   is employed:  FTPSysMail-Directory.Bravo

SysMailPrimitives,
SomeMailPrimitives: PUBLIC PROCEDURE RETURNS [mailPrimitives: MailPrimitives] =
  BEGIN
  -- return mail primitives
    mailPrimitives _ @mailPrimitivesObject;
  END;
 
-- **********************!  Mail Primitives  !***********************

CreateMailSystem: PROCEDURE [filePrimitives: FilePrimitives, bufferSize: CARDINAL] RETURNS [mailSystem: MailSystem, forwardingProvided: BOOLEAN] =
  BEGIN
  -- Note:  bufferSize expressed in pages; zero implies default.
  -- local constants
    stagingFile: STRING = [maxStringLength];
  -- local variables
    sysMailSystem: SysMailSystem;
  -- verify presence of file primitives
    IF filePrimitives = NIL THEN Abort[filePrimitivesNotSpecified];
  -- allocate and initialize mail system object
    sysMailSystem _ Storage.Node[SIZE[SysMailSystemObject]];
    sysMailSystem^ _ SysMailSystemObject[
      filePrimitives: filePrimitives,
      fileSystem: NIL,
      directoryFileHandle: NIL, stagingFileHandle: NIL,
      messageLength: ];
    mailSystem _ LOOPHOLE[sysMailSystem];
  -- initialize mailbox queue
    IF (useCount _ useCount+1) = 1 THEN
      InitializeQueue[@mailboxQueueObject, String.EquivalentString];
  -- create file system
    BEGIN OPEN sysMailSystem; ENABLE UNWIND => DestroyMailSystem[mailSystem];
    fileSystem _ filePrimitives.CreateFileSystem[bufferSize];
  -- open mailbox directory file for read
    [directoryFileHandle, ] _
      filePrimitives.OpenFile[fileSystem, "FTPSysMail-Directory.Bravo"L, read, FALSE, NIL];
  -- open staging file for writeThenRead
  -- Note:  stagingFile.length=0, requesting creation of scratch file.
    [stagingFileHandle,  ] _
      filePrimitives.OpenFile[fileSystem, stagingFile, writeThenRead, FALSE, NIL];
  -- decline to forward messages
    forwardingProvided _ FALSE;
    END; -- enable
  END;

DestroyMailSystem: PROCEDURE [mailSystem: MailSystem] =
  BEGIN
  -- local constants
    sysMailSystem: SysMailSystem = LOOPHOLE[mailSystem];
  -- close staging file
  -- Note: aborted=TRUE, requesting deletion of scratch file.
    BEGIN OPEN sysMailSystem;
    IF stagingFileHandle # NIL THEN
      filePrimitives.CloseFile[fileSystem, stagingFileHandle, TRUE];
  -- close mailbox directory file
    IF directoryFileHandle # NIL THEN
      filePrimitives.CloseFile[fileSystem, directoryFileHandle, FALSE];
  -- destroy file system
    IF fileSystem # NIL THEN filePrimitives.DestroyFileSystem[fileSystem];
  -- finalize mailbox queue
    IF (useCount _ useCount-1) = 0 THEN FinalizeQueue[@mailboxQueueObject];
  -- release mail system object
    Storage.Free[sysMailSystem];
    END; -- open
  END;

InspectCredentials: PROCEDURE [mailSystem: MailSystem, status: Status, user, password: STRING] =
  BEGIN
  -- no operation
  END;

LocateMailboxes: PROCEDURE [mailSystem: MailSystem, localMailboxList: Mailbox] =
  BEGIN
  -- Note:  Skips mailboxes showing located=TRUE; allocates location from the heap.
  -- EnumerateMailboxes appendage
    NoteMailbox: PROCEDURE [definedMailbox, file: STRING] =
      BEGIN
      -- search mailbox list for defined mailbox
        FOR localMailboxList _ localMailboxListHead, localMailboxList.nextMailbox
            UNTIL localMailboxList=NIL DO OPEN localMailboxList;
          IF ~located AND String.EquivalentString[mailbox, definedMailbox] THEN
            BEGIN
            location _ Storage.CopyString[file];
            located _ String.EquivalentString[mailbox, definedMailbox];
            END;
          ENDLOOP;
      END;
  -- local constants
    sysMailSystem: SysMailSystem = LOOPHOLE[mailSystem];
    localMailboxListHead: Mailbox = localMailboxList;
  -- enumerate defined mailboxes
    EnumerateMailboxes[sysMailSystem, NoteMailbox];
  END;

StageMessage: PROCEDURE [mailSystem: MailSystem, receiveBlock: PROCEDURE [UNSPECIFIED, POINTER, CARDINAL] RETURNS [CARDINAL], receiveBlockData: UNSPECIFIED] =
  BEGIN
  -- Note:  Records messageLength.
  -- ReceiveBlock procedure
    ReceiveBlock: PROCEDURE [unused: UNSPECIFIED, destination: POINTER,
        maxWordCount: CARDINAL] RETURNS [actualByteCount: CARDINAL] =
      BEGIN OPEN sysMailSystem;
      -- receive block
        actualByteCount _ receiveBlock[receiveBlockData, destination, maxWordCount];
      -- increment message length
        messageLength _ messageLength + actualByteCount;
      END;
  -- local constants
    sysMailSystem: SysMailSystem = LOOPHOLE[mailSystem];
  -- stage message
    BEGIN OPEN sysMailSystem;
    messageLength _ 0;
    filePrimitives.WriteFile[fileSystem, stagingFileHandle, ReceiveBlock, NIL];
    END; -- open
  END;

DeliverMessage: PROCEDURE [mailSystem: MailSystem, localMailboxList: Mailbox] =
  BEGIN
  -- Note:  Assumes message text staged;
  --   skips mailboxes showing located=FALSE or delivered=TRUE;
  --   suppresses errors raised in individual delivery attempts.
  -- local constants
    sysMailSystem: SysMailSystem = LOOPHOLE[mailSystem];
    localMailboxListHead: Mailbox = localMailboxList;
    textualDateAndTime: STRING = [maxStringLength];
    textualMessageLength: STRING = [maxStringLength];
  -- note date and time and message length
    BEGIN OPEN sysMailSystem;
    Time.AppendCurrent[textualDateAndTime];
    String.AppendLongNumber[textualMessageLength, messageLength, 10];
  -- deliver message
    FOR localMailboxList _ localMailboxListHead, localMailboxList.nextMailbox
        UNTIL localMailboxList=NIL DO OPEN localMailboxList;
      IF located AND ~delivered THEN
        BEGIN ENABLE FTPError => CONTINUE;
        DeliverMessageToMailbox[sysMailSystem, textualDateAndTime, textualMessageLength, location];
        delivered _ TRUE;
        END;
      ENDLOOP;
    END; -- open
  END;

ForwardMessage: PROCEDURE [mailSystem: MailSystem, remoteMailboxList: Mailbox] =
  BEGIN
  -- Note:  Assumes message text staged;
  --   skips mailboxes showing delivered=TRUE;
  --   suppresses errors raised in individual forwarding attempts.
  -- not implemented
  END;

RetrieveMessages: PROCEDURE [mailSystem: MailSystem, localMailbox: Mailbox, processMessage: PROCEDURE [MessageInfo], sendBlock: PROCEDURE [UNSPECIFIED, POINTER, CARDINAL], sendBlockData: UNSPECIFIED] =
  BEGIN OPEN localMailbox;
  -- Note:  Assumes localMailbox is of length 1 showing located=TRUE;
  --   invocation of processMessage with byteCount=0 signifies end of file and
  --   precedes flushing of mailbox; assumes date and time and message lengths
  --   are free of the delimiters:
  --     dateAndTimeTerminator and messageLengthTerminator.
  -- ReadMessages procedure
    ReadMessages: PROCEDURE =
      BEGIN OPEN sysMailSystem;
      -- SendBlock procedure
        SendBlock: PROCEDURE [unused: UNSPECIFIED, source: POINTER, byteCount: CARDINAL] =
          BEGIN
          -- local variables
            bytePointerObject: BytePointerObject _ [source, FALSE, byteCount];
            character: CHARACTER;
            wordObject: WordObject;
          -- check for premature end-of-file
            IF byteCount = 0 AND (string # textualDateAndTime OR string.length # 0
            OR messageInfoObject.byteCount # 0) THEN Abort[unexpectedEndOfFile];
          -- consume source data
            UNTIL bytePointerObject.count = 0 DO
              SELECT TRUE FROM
                (messageInfoObject.byteCount = 0) =>
                  SELECT character _ LOOPHOLE[LoadByte[@bytePointerObject]] FROM
                    dateAndTimeTerminator => string _ textualMessageLength;
                    messageLengthTerminator =>
                      BEGIN
                      messageInfoObject.byteCount _
                        String.StringToLongNumber[textualMessageLength, 10];
                      processMessage[@messageInfoObject];
                      textualDateAndTime.length _ textualMessageLength.length _ 0;
                      string _ textualDateAndTime;
                      END;
                    ENDCASE => String.AppendChar[string, character];
                (messageInfoObject.byteCount > 0 AND bytePointerObject.offset) =>
                  BEGIN
                  wordObject.lhByte _ LoadByte[@bytePointerObject];
                  sendBlock[sendBlockData, @wordObject, 1];
                  messageInfoObject.byteCount _ messageInfoObject.byteCount - 1;
                  END;
                ENDCASE =>
                  BEGIN
                  byteCount _ MIN[bytePointerObject.count,
                    IF messageInfoObject.byteCount > LAST[CARDINAL]
                      THEN LAST[CARDINAL]
                      ELSE Inline.LowHalf[messageInfoObject.byteCount]];
                  sendBlock[sendBlockData, bytePointerObject.address, byteCount];
                  AdvanceBytePointer[@bytePointerObject, byteCount];
                  messageInfoObject.byteCount _ messageInfoObject.byteCount - byteCount;
                  END;
              ENDLOOP;
          END;
      -- local constants
        textualDateAndTime: STRING = [maxStringLength];
        textualMessageLength: STRING = [maxStringLength];
      -- local variables
        fileHandle: FileHandle _ NIL;
        string: STRING _ textualDateAndTime;
        messageInfoObject: MessageInfoObject _ [
          byteCount: 0, deliveryDate: textualDateAndTime,
          opened: FALSE, deleted: FALSE];
      -- open mailbox file for readThenWrite
        [fileHandle, ] _ filePrimitives.OpenFile[fileSystem, location, readThenWrite, FALSE, NIL
            ! FTPError => IF ftpError = noSuchFile THEN CONTINUE];
        IF fileHandle = NIL THEN
          BEGIN
          processMessage[@messageInfoObject];
          RETURN;
          END;
        BEGIN ENABLE UNWIND => filePrimitives.CloseFile[fileSystem, fileHandle, FALSE];
      -- read messages:  date and time, message length, and text
        filePrimitives.ReadFile[fileSystem, fileHandle, SendBlock, NIL];
      -- signal end of file
        processMessage[@messageInfoObject];
      -- close mailbox file
      -- Note:  aborted=TRUE, requesting deletion of file.
        END; -- enable
        filePrimitives.CloseFile[fileSystem, fileHandle, TRUE];
      END;
  -- local constants
    sysMailSystem: SysMailSystem = LOOPHOLE[mailSystem];
  -- retrieve messages
    ManipulateMailbox[location, ReadMessages];
  END;

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

EnumerateMailboxes: PROCEDURE [sysMailSystem: SysMailSystem, processMailbox: PROCEDURE [STRING, STRING]] =
  BEGIN OPEN sysMailSystem;
  -- Note:  Assumes mailbox names and filenames are free of the delimiters:
  --   mailboxTerminator and fileTerminator.
  -- SendBlock procedure
    SendBlock: PROCEDURE [unused: UNSPECIFIED, source: POINTER, byteCount: CARDINAL] =
      BEGIN
      -- local variables
        bytePointerObject: BytePointerObject _ [source, FALSE, byteCount];
        character: CHARACTER;
      -- check for premature end of file
        IF byteCount = 0 AND (string = file OR string.length # 0) THEN
          Abort[unexpectedEndOfFile];
      -- consume source data
        UNTIL bytePointerObject.count = 0 DO
          SELECT character _ LOOPHOLE[LoadByte[@bytePointerObject]] FROM
            mailboxTerminator => string _ file;
            fileTerminator =>
              BEGIN
              processMailbox[mailbox, file];
              mailbox.length _ file.length _ 0;
              string _ mailbox;
              END;
            ENDCASE => String.AppendChar[string, character];
          ENDLOOP; 
      END;
  -- local constants
    mailbox: STRING = [maxStringLength];
    file: STRING = [maxStringLength];
  -- local variables
    string: STRING _ mailbox;
  -- enumerate mailboxes
    filePrimitives.ReadFile[fileSystem, directoryFileHandle, SendBlock, NIL];
  END;

DeliverMessageToMailbox: PROCEDURE [sysMailSystem: SysMailSystem, textualDateAndTime, textualMessageLength, file: STRING] =
  BEGIN OPEN sysMailSystem;
  -- Note:  Assumes text of message in staging file;
  --   assumes date and time and message length are free of the delimiters:
  --     dateAndTimeTerminator and messageLengthTerminator.
  -- WriteMessage procedure
    WriteMessage: PROCEDURE =
      BEGIN
      -- ReceiveBlock Procedure
        ReceiveBlock: PROCEDURE [unused: UNSPECIFIED, destination: POINTER,
            maxWordCount: CARDINAL] RETURNS [actualByteCount: CARDINAL] =
          BEGIN
          -- local variables
            bytePointerObject: BytePointerObject _
              [destination, FALSE, bytesPerWord*maxWordCount];
            character: CHARACTER;
          -- produce destination data
            UNTIL bytePointerObject.count = 0 OR endOfHeader DO
              SELECT TRUE FROM
                (index < string.length) =>
                  BEGIN
                  character _ string[index];
                  index _ index + 1;
                  END;
                (string = textualDateAndTime) =>
                  BEGIN
                  character _ dateAndTimeTerminator;
                  string _ textualMessageLength;
                  index _ 0;
                  END;
                ENDCASE =>
                  BEGIN
                  character _ messageLengthTerminator;
                  endOfHeader _ TRUE;
                  END;
              StoreByte[@bytePointerObject, LOOPHOLE[character]];
              ENDLOOP;
          -- compute actual byte count for caller
            actualByteCount _ bytesPerWord*maxWordCount - bytePointerObject.count;
          END;
      -- local variables
        fileHandle: FileHandle;
        string: STRING _ textualDateAndTime;
        index: CARDINAL _ 0;
        endOfHeader: BOOLEAN _ FALSE;
      -- open file for append
        [fileHandle, ] _ filePrimitives.OpenFile[fileSystem, file, append, FALSE, NIL];
        BEGIN ENABLE UNWIND => filePrimitives.CloseFile[fileSystem, fileHandle, TRUE];
      -- write message:  date and time, message length, and text
        filePrimitives.WriteFile[fileSystem, fileHandle, ReceiveBlock, NIL];
        ForkTransferPair[fileSystem, filePrimitives.ReadFile, stagingFileHandle, filePrimitives.WriteFile, fileHandle];
      -- close file
        END; -- enable
        filePrimitives.CloseFile[fileSystem, fileHandle, FALSE];
      END;
  -- deliver message to mailbox
    ManipulateMailbox[file, WriteMessage];
  END;

ManipulateMailbox: PROCEDURE [file: STRING, procedure: PROCEDURE] =
  BEGIN
  -- local variables
    mailboxQueueElement: Element _ NIL;
  -- enqueue mailbox element
    mailboxQueueElement _ EnQueue[@mailboxQueueObject, NIL, file];
    BEGIN ENABLE UNWIND =>
      BEGIN
      IF mailboxQueueElement.locked THEN
        UnlockQueue[@mailboxQueueObject, mailboxQueueElement];
      IF mailboxQueueElement # NIL THEN
        DeQueue[@mailboxQueueObject, mailboxQueueElement];
      END;
  -- lock file
    LockQueue[@mailboxQueueObject, mailboxQueueElement, TRUE];
  -- dispatch caller
    procedure[];
  -- unlock file
    UnlockQueue[@mailboxQueueObject, mailboxQueueElement];
  -- dequeue mailbox element
    END; -- enable
    DeQueue[@mailboxQueueObject, mailboxQueueElement];
  END;

StoreByte: PUBLIC PROCEDURE [dstBytePointer: BytePointer, byte: Byte] =
  BEGIN
  -- Note:  Doesn't check for byte pointer exhaustion.
  -- local constants
    dBP: BytePointer = dstBytePointer;
    dWord: Word = dBP.address;
  -- store byte
    IF dBP.offset THEN dWord.rhByte _ byte ELSE dWord.lhByte _ byte;
  -- advance address and offset
    IF ~(dBP.offset _ ~dBP.offset) THEN dBP.address _ dBP.address + 1;
  -- decrement byte count
    dBP.count _ dBP.count - 1;
  END;

LoadByte: PUBLIC PROCEDURE [srcBytePointer: BytePointer] RETURNS [byte: Byte] =
  BEGIN
  -- Note:  Doesn't check for byte pointer exhaustion.
  -- local constants
    sBP: BytePointer = srcBytePointer;
    sWord: Word = sBP.address;
  -- load byte
    byte _ IF sBP.offset THEN sWord.rhByte ELSE sWord.lhByte;
  -- advance address and offset
    IF ~(sBP.offset _ ~sBP.offset) THEN sBP.address _ sBP.address + 1;
  -- decrement byte count
    sBP.count _ sBP.count - 1;
  END;
-- **********************!  Main Program  !***********************

-- no operation    

END. -- of FTPSysMail