-- file: FTPServerMail.mesa -- Edited by: HGM July 28, 1980 9:13 PM -- Copyright Xerox Corporation 1979, 1980 DIRECTORY FTPDefs, FTPPrivateDefs, String USING [AppendChar, AppendDecimal, AppendLongNumber], Storage USING [Node, Free, FreeString]; FTPServerMail: PROGRAM -- import list IMPORTS 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 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; -- local variables headLocalMailbox, headRemoteMailbox: Mailbox _ NIL; mailbox: Mailbox; number: CARDINAL _ 0; atLeastOneValidRecipient: BOOLEAN _ FALSE; -- intercept errors BEGIN ENABLE UNWIND => BEGIN DequeueMailboxes[@headLocalMailbox]; DequeueMailboxes[@headRemoteMailbox]; END; -- receive distribution list and EOC DO -- receive property list GetPropertyList[ ftper, propertyList ! FTPError => IF ftpError = protocolParameterListMissing THEN EXIT]; -- enqueue local/remote mailbox EnqueueMailbox[@headLocalMailbox, propertyList, number _ number + 1]; ENDLOOP; GetEOC[ftper]; -- reject unsupported forwarding requests IF headRemoteMailbox # NIL THEN IF forwardingProvided THEN atLeastOneValidRecipient _ TRUE ELSE FOR mailbox _ headRemoteMailbox, mailbox.nextMailbox UNTIL mailbox = NIL DO PutMailboxException[mailbox.number, noForwardingProvided]; ENDLOOP; -- reject undefined local mailboxes IF headLocalMailbox # NIL THEN BEGIN -- locate mailboxes mailPrimitives.LocateMailboxes[mailSystem, headLocalMailbox]; -- issue necessary mailbox exceptions FOR mailbox _ headLocalMailbox, mailbox.nextMailbox UNTIL mailbox = NIL DO IF mailbox.located THEN atLeastOneValidRecipient _ TRUE ELSE PutMailboxException[mailbox.number, noSuchMailbox]; ENDLOOP; END; -- send preliminary approval of distribution list IF atLeastOneValidRecipient THEN PutCommandAndEOC[ftper, markYes, 0] ELSE Abort[noValidRecipients]; -- stage message text GetSpecificCommand[ftper, markHereIsFile]; mailPrimitives.StageMessage[mailSystem, ReceiveBlock, ftper]; GetYesAndEOC[ftper]; -- deliver message to local mailboxes IF headLocalMailbox # NIL THEN BEGIN -- deliver message mailPrimitives.DeliverMessage[mailSystem, headLocalMailbox]; -- issue necessary mailbox exceptions FOR mailbox _ headLocalMailbox, mailbox.nextMailbox UNTIL mailbox = NIL DO IF mailbox.located AND ~mailbox.delivered THEN PutMailboxException[mailbox.number, unspecifiedError]; ENDLOOP; END; -- forward message to remote mailboxes IF headRemoteMailbox # NIL THEN BEGIN -- forward message mailPrimitives.ForwardMessage[mailSystem, headRemoteMailbox]; -- issue necessary mailbox exceptions FOR mailbox _ headRemoteMailbox, mailbox.nextMailbox UNTIL mailbox = NIL DO IF ~mailbox.delivered THEN PutMailboxException[mailbox.number, unspecifiedError]; ENDLOOP; END; -- send Yes and EOC PutCommandAndEOC[ftper, markYes, 0]; -- dequeue distribution list DequeueMailboxes[@headLocalMailbox]; DequeueMailboxes[@headRemoteMailbox]; 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 EnqueueMailbox[@mailbox, propertyList, 1]; BEGIN ENABLE UNWIND => DequeueMailboxes[@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]; -- dequeue mailbox END; -- enable DequeueMailboxes[@mailbox]; END; -- **********************! Mailbox Primitives !*********************** EnqueueMailbox: PROCEDURE [ headMailbox: POINTER TO Mailbox, propertyList: PropertyList, number: CARDINAL] = BEGIN -- Note: Assumes nextMailbox=NIL; updates headMailbox^ if NIL. -- local variables mailbox, tailMailbox: Mailbox; -- create mailbox mailbox _ CreateMailbox[propertyList, number]; -- queue is empty: make mailbox the head IF headMailbox^ = NIL THEN headMailbox^ _ mailbox -- queue is not empty: append mailbox to it ELSE BEGIN FOR tailMailbox _ headMailbox^, tailMailbox.nextMailbox UNTIL tailMailbox.nextMailbox = NIL DO ENDLOOP; tailMailbox.nextMailbox _ mailbox; END; END; DequeueMailboxes: PROCEDURE [headMailbox: POINTER TO Mailbox] = BEGIN -- Note: Resets headMailbox^ to NIL. -- local variables mailbox, nextMailbox: Mailbox; -- destroy each mailbox FOR mailbox _ headMailbox^, nextMailbox UNTIL mailbox = NIL DO nextMailbox _ mailbox.nextMailbox; DestroyMailbox[mailbox]; ENDLOOP; -- reset queue headMailbox^ _ NIL; 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