-- Transport Mechanism Mail Server - server for MTP -- -- [Indigo]MS>MTPServer.mesa -- HGM, 13-Nov-84 1:51:24 -- Randy Gobbel 29-May-81 14:46:16 -- -- Andrew Birrell 29-Dec-81 15:00:20 -- -- Mark Johnson May 28, 1981 2:39 PM -- -- Brenda Hankins 10-Aug-84 15:41:12 Klamath update (replace STOP with 2 init procs) DIRECTORY BodyDefs USING [ItemLength, maxRNameLength, RName, Timestamp], FTPDefs, HeapDefs USING [ HeapAbandonWrite, HeapEndRead, HeapReadData, HeapReadRName, HeapStartRead, HeapStartWrite, HeapWriteData, HeapWriteRName, ObjectNumber, objectStart, ReaderHandle, SetReaderOffset, WriterHandle], LocalNameDefs USING [ReadMSName], LogDefs USING [WriteLogEntry], NameInfoDefs USING [ CheckStamp, Close, Enumerate, GetMembers, GetRemark, MemberInfo, NameType, RListHandle], PolicyDefs USING [CheckOperation, EndOperation, WaitOperation], Process USING [Detach], ProtocolDefs USING [AppendTimestamp, maxRemarkLength, Remark], PupDefs USING [ParsePupAddressConstant, PupAddress], ReturnDefs USING [CopyItem, ParseBody, RejectedByMTP], RestartDefs USING [] --EXPORT only-- , ServerDefs USING [DownServer, ServerUp], SiteCacheDefs USING [SingleFlush, ValidateRName], SLDefs USING [ GetCount, SLHeader, SLEndRead, SLStartRead, SLReadHandle, SLTransfer, SLWrite], Storage USING [Free, FreeString, Node, String], String USING [AppendDecimal, AppendString, EquivalentStrings], Time USING [Current]; MTPServer: MONITOR IMPORTS FTPDefs, HeapDefs, LocalNameDefs, LogDefs, NameInfoDefs, PolicyDefs, Process, ProtocolDefs, PupDefs, ReturnDefs, ServerDefs, SiteCacheDefs, SLDefs, Storage, String, Time EXPORTS RestartDefs = BEGIN RNameFromString: PROCEDURE [s: STRING] RETURNS [BOOLEAN] = BEGIN RETURN[s.length <= BodyDefs.maxRNameLength] END; MailSystemObject: TYPE = RECORD [ net, host: [0..256), -- FTPServerMail assumes these are first -- credentialsOK: BOOLEAN]; WhoIsHe: SIGNAL RETURNS [net, host: [0..256)] = CODE; --communication between CreateMailSystem and Backstop -- CreateMailSystem: PROCEDURE [ filePrimitives: FTPDefs.FilePrimitives, bufferSize: CARDINAL] RETURNS [mailSystem: FTPDefs.MailSystem, forwardingProvided: BOOLEAN] = BEGIN real: POINTER TO MailSystemObject = Storage.Node[SIZE[MailSystemObject]]; real.credentialsOK ¬ FALSE; [real.net, real.host] ¬ SIGNAL WhoIsHe[]; RETURN[LOOPHOLE[real, FTPDefs.MailSystem], FALSE] END; DestroyMailSystem: PROCEDURE [mailSystem: FTPDefs.MailSystem] = BEGIN Storage.Free[mailSystem]; END; InspectCredentials: PROCEDURE [ mailSystem: FTPDefs.MailSystem, status: FTPDefs.Status, user, password: STRING] = BEGIN END; LocateMailboxes: PROCEDURE [ mailSystem: FTPDefs.MailSystem, localMailboxList: FTPDefs.Mailbox] = BEGIN mbx: FTPDefs.Mailbox; FOR mbx ¬ localMailboxList, mbx.nextMailbox WHILE mbx # NIL DO IF mbx.located THEN LOOP; mbx.located ¬ RNameFromString[mbx.mailbox] AND SiteCacheDefs.ValidateRName[mbx.mailbox]; ENDLOOP; END; StageMessage: PROCEDURE [ mailSystem: FTPDefs.MailSystem, receiveBlock: PROCEDURE [UNSPECIFIED, POINTER, CARDINAL] RETURNS [CARDINAL], receiveBlockData: UNSPECIFIED] = BEGIN ERROR; END; DeliverMessage: PROCEDURE [ mailSystem: FTPDefs.MailSystem, localMailboxList: FTPDefs.Mailbox] = BEGIN ERROR; END; DummyForward: PROCEDURE [ mailSystem: FTPDefs.MailSystem, remoteMailboxList: FTPDefs.Mailbox] = BEGIN ERROR; END; RetrieveMessages: PROCEDURE [ mailSystem: FTPDefs.MailSystem, localMailbox: FTPDefs.Mailbox, processMessage: PROCEDURE [FTPDefs.MessageInfo], sendBlock: PROCEDURE [UNSPECIFIED, POINTER, CARDINAL], sendBlockData: UNSPECIFIED] = BEGIN ERROR FTPDefs.FTPError[ unidentifiedPermanentError, "MTP retrieval not supported"L]; END; myMailPrimitives: FTPDefs.MailPrimitivesObject ¬ [ CreateMailSystem, DestroyMailSystem, InspectCredentials, LocateMailboxes, StageMessage, DeliverMessage, DummyForward, RetrieveMessages]; -- DL expansion for MTP socket -- CreateDL: PROC [bufferSize: CARDINAL] RETURNS [fileSystem: FTPDefs.FileSystem] = BEGIN RETURN[LOOPHOLE[NIL]]; END; DestroyDL: PROC [fileSystem: FTPDefs.FileSystem] = {}; DecomposeDL: PROC [ fileSystem: FTPDefs.FileSystem, absoluteFilename: STRING, virtualFilename: FTPDefs.VirtualFilename] = BEGIN virtualFilename.device.length ¬ 0; virtualFilename.directory.length ¬ 0; virtualFilename.name.length ¬ 0; String.AppendString[virtualFilename.name, absoluteFilename]; virtualFilename.version.length ¬ 0; END; ComposeDL: PROC [ fileSystem: FTPDefs.FileSystem, absoluteFilename: STRING, virtualFilename: FTPDefs.VirtualFilename] = BEGIN IF virtualFilename.device.length = 0 AND virtualFilename.directory.length = 0 AND virtualFilename.name.length = 0 AND virtualFilename.version.length = 0 THEN NULL -- that's what the spec says! -- ELSE BEGIN absoluteFilename.length ¬ 0; String.AppendString[absoluteFilename, virtualFilename.name]; END; END; InspectCredentialsDL: PROC [ fileSystem: FTPDefs.FileSystem, status: FTPDefs.Status, user, password: STRING] = {}; EnumerateDL: PROCEDURE [ fileSystem: FTPDefs.FileSystem, files: STRING, intent: FTPDefs.EnumerateFilesIntent, processFile: PROC [UNSPECIFIED, STRING, FTPDefs.FileInfo], processFileData: UNSPECIFIED] = BEGIN fileInfoObject: FTPDefs.FileInfoObject ¬ [ fileType: text, byteSize: 8, byteCount: 0, creationDate: NIL, writeDate: NIL, readDate: NIL, author: NIL]; processFile[processFileData, files, @fileInfoObject]; END; MyDLHandle: TYPE = RECORD [name: STRING, members: NameInfoDefs.RListHandle]; OpenDL: PROCEDURE [ fileSystem: FTPDefs.FileSystem, file: STRING, mode: FTPDefs.Mode, fileTypePlease: BOOLEAN, info: FTPDefs.FileInfo] RETURNS [fileHandle: FTPDefs.FileHandle, fileType: FTPDefs.FileType] = BEGIN IF mode = read THEN BEGIN myHandle: POINTER TO MyDLHandle = Storage.Node[SIZE[MyDLHandle]]; info: NameInfoDefs.MemberInfo = NameInfoDefs.GetMembers[file]; WITH info SELECT FROM allDown => FTPDefs.FTPError[fileBusy, "Registration server not available"L]; notFound => FTPDefs.FTPError[noSuchFile, "Distribution list not found"L]; individual => FTPDefs.FTPError[noSuchFile, "Not a distribution list"L]; group => myHandle.members ¬ members; ENDCASE => ERROR; myHandle.name ¬ file; fileHandle ¬ LOOPHOLE[myHandle]; fileType ¬ text; END ELSE FTPDefs.FTPError[ requestedAccessDenied, "Distribution lists are read-only"L]; END; ReadDL: PROC [ fileSystem: FTPDefs.FileSystem, fileHandle: FTPDefs.FileHandle, sendBlock: PROC [UNSPECIFIED, POINTER, CARDINAL], sendBlockData: UNSPECIFIED] = BEGIN myHandle: POINTER TO MyDLHandle = LOOPHOLE[fileHandle]; head: STRING = ": "L; pad: STRING = ", "L; tail: STRING = ";"L; first: BOOLEAN ¬ TRUE; SendDL: PROC [ memberList: NameInfoDefs.RListHandle, testRecursion: PROC [new: BodyDefs.RName] RETURNS [BOOLEAN]] = BEGIN Work: PROC [member: BodyDefs.RName] RETURNS [done: BOOLEAN] = BEGIN DoneThis: PROC [new: BodyDefs.RName] RETURNS [BOOLEAN] = BEGIN -- Mechanism for eliminating recursive loops -- RETURN[ IF String.EquivalentStrings[member, new] THEN TRUE ELSE testRecursion[new]] END; info: NameInfoDefs.MemberInfo; skip: BOOLEAN ¬ FALSE; FOR index: CARDINAL IN [0..member.length) DO IF member[index] = '^ THEN BEGIN -- consider group -- IF testRecursion[member] THEN skip ¬ TRUE ELSE info ¬ NameInfoDefs.GetMembers[member]; EXIT END; REPEAT FINISHED => info ¬ [individual[]]; ENDLOOP; done ¬ FALSE; IF NOT skip THEN WITH info SELECT FROM allDown, notFound, individual => BEGIN IF first THEN first ¬ FALSE ELSE sendBlock[sendBlockData, @(pad.text), pad.length]; sendBlock[sendBlockData, @(member.text), member.length]; END; group => BEGIN SendDL[members, DoneThis ! UNWIND => NameInfoDefs.Close[members]]; NameInfoDefs.Close[members]; END; ENDCASE => ERROR; END; NameInfoDefs.Enumerate[memberList, Work]; END; DoneTopLevel: PROC [new: BodyDefs.RName] RETURNS [BOOLEAN] = -- top level of recursive loop elimination -- {RETURN[String.EquivalentStrings[myHandle.name, new]]}; BEGIN remark: ProtocolDefs.Remark = [ProtocolDefs.maxRemarkLength]; info: NameInfoDefs.NameType = NameInfoDefs.GetRemark[myHandle.name, remark]; IF info # group THEN String.AppendString[remark, myHandle.name]; IF remark.length > 0 THEN BEGIN sendBlock[sendBlockData, @(remark.text), remark.length]; sendBlock[sendBlockData, @(head.text), head.length]; END; SendDL[myHandle.members, DoneTopLevel]; IF remark.length > 0 THEN sendBlock[sendBlockData, @(tail.text), tail.length]; END; END; WriteDL: PROC [ fileSystem: FTPDefs.FileSystem, fileHandle: FTPDefs.FileHandle, receiveBlock: PROC [UNSPECIFIED, POINTER, CARDINAL] RETURNS [CARDINAL], receiveBlockData: UNSPECIFIED] = { ERROR FTPDefs.FTPError[requestedAccessDenied, "Don't be silly!"L]}; DeleteDL: PROC [fileSystem: FTPDefs.FileSystem, file: STRING] = { ERROR FTPDefs.FTPError[requestedAccessDenied, "Don't be silly!"L]}; RenameDL: PROC [fileSystem: FTPDefs.FileSystem, currentFile, newFile: STRING] = {ERROR FTPDefs.FTPError[requestedAccessDenied, "Don't be silly!"L]}; CloseDL: PROC [ fileSystem: FTPDefs.FileSystem, fileHandle: FTPDefs.FileHandle, aborted: BOOLEAN] = BEGIN myHandle: POINTER TO MyDLHandle = LOOPHOLE[fileHandle]; NameInfoDefs.Close[myHandle.members]; Storage.Free[myHandle]; END; myDLPrimitives: FTPDefs.FilePrimitivesObject ¬ [ CreateFileSystem: CreateDL, DestroyFileSystem: DestroyDL, DecomposeFilename: DecomposeDL, ComposeFilename: ComposeDL, InspectCredentials: InspectCredentialsDL, EnumerateFiles: EnumerateDL, OpenFile: OpenDL, ReadFile: ReadDL, WriteFile: WriteDL, CloseFile: CloseDL, DeleteFile: DeleteDL, RenameFile: RenameDL]; -- Forwarding to foreign servers -- ftpUser: FTPDefs.FTPUser = FTPDefs.FTPCreateUser[ filePrimitives: NIL, communicationPrimitives: FTPDefs.PupCommunicationPrimitives[]]; ForwardOutcome: TYPE = {ok, bad, tempFailure, totalFailure}; ForwardMessage: ENTRY PROCEDURE [ host: STRING, SLhandle: SLDefs.SLReadHandle, SLobj: HeapDefs.ReaderHandle, body: HeapDefs.ObjectNumber, slHeader: POINTER TO SLDefs.SLHeader] = BEGIN bodyReader: HeapDefs.ReaderHandle ¬ HeapDefs.HeapStartRead[body]; ended: BOOLEAN; outcome: ForwardOutcome ¬ ok; goodCount: CARDINAL ¬ 0; badCount: CARDINAL ¬ 0; wrongCount: CARDINAL ¬ 0; badList: HeapDefs.WriterHandle ¬ NIL; badString: STRING ¬ NIL; wrongList: HeapDefs.WriterHandle ¬ NIL; MakeBad: PROC [bad: BodyDefs.RName] = BEGIN SiteCacheDefs.SingleFlush[bad]; IF NameInfoDefs.CheckStamp[bad] = notFound OR slHeader.created.time + 24 * LONG[60 * 60] < Time.Current[] THEN -- Either name went bad, or name is foreign and bad, -- or GV disagrees with MTP and we've waited long enough -- BEGIN IF badList = NIL THEN badList ¬ HeapDefs.HeapStartWrite[temp]; HeapDefs.HeapWriteRName[badList, bad]; badCount ¬ badCount + 1; END ELSE -- GV database disagrees with MTP host: wait until they converge, -- or until the long-term timeout on the message. -- BEGIN IF wrongList = NIL THEN BEGIN wrongList ¬ HeapDefs.HeapStartWrite[SLpending]; HeapDefs.HeapWriteData[wrongList, [slHeader, SIZE[SLDefs.SLHeader]]]; END; HeapDefs.HeapWriteRName[wrongList, bad]; wrongCount ¬ wrongCount + 1; END; END; CheckRecipients: PROCEDURE = BEGIN msg: STRING = [128]; badRecipient: BodyDefs.RName = [BodyDefs.maxRNameLength]; error: FTPDefs.RecipientError; number: CARDINAL; ended: BOOLEAN; DO [number, error] ¬ FTPDefs.FTPIdentifyNextRejectedRecipient[ftpUser, msg]; IF number = 0 THEN EXIT; goodCount ¬ goodCount - 1; -- search SL for recipient -- HeapDefs.SetReaderOffset[SLobj, SIZE[SLDefs.SLHeader]]; ended ¬ FALSE; UNTIL ended OR number = 0 DO ended ¬ HeapDefs.HeapReadRName[SLobj, badRecipient]; number ¬ number - 1; ENDLOOP; IF number = 0 THEN BEGIN outcome ¬ bad; IF badString = NIL THEN BEGIN badString ¬ Storage.String[msg.length]; String.AppendString[badString, msg]; END; MakeBad[badRecipient]; END; ENDLOOP; END; IF NOT ServerDefs.ServerUp[slHeader.server] THEN outcome ¬ tempFailure ELSE BEGIN ENABLE FTPDefs.FTPError => SELECT ftpError FROM noNameLookupResponse, connectionTimedOut, connectionClosed, connectionRejected, noRouteToNetwork, unidentifiedTransientError => GOTO tempFailure; noValidRecipients => GOTO nobody; ENDCASE -- includes: noSuchHost, unidentifiedPermanentError -- => BEGIN OPEN String; IF ftpError = noSuchHost THEN message ¬ "server does not exist"L; IF message = NIL OR message.length = 0 THEN message ¬ "No message given"L; IF badString # NIL THEN Storage.FreeString[badString]; badString ¬ Storage.String[message.length]; AppendString[badString, message]; GOTO totalFailure END; bodyLength: BodyDefs.ItemLength; BEGIN sender: BodyDefs.RName = [BodyDefs.maxRNameLength]; bodyLength ¬ ReturnDefs.ParseBody[reader: bodyReader, sender: sender]; FTPDefs.FTPOpenConnection[ftpUser, host, mail, NIL]; FTPDefs.FTPSetCredentials[ftpUser, primary, sender, NIL]; END; FTPDefs.FTPBeginDeliveryOfMessage[ftpUser]; BEGIN recipient: BodyDefs.RName = [BodyDefs.maxRNameLength]; [ended, ] ¬ HeapDefs.HeapReadData[SLobj, [recipient, 0]]; UNTIL ended DO ended ¬ HeapDefs.HeapReadRName[SLobj, recipient]; FTPDefs.FTPSendRecipientOfMessage[ftpUser, recipient]; goodCount ¬ goodCount + 1; ENDLOOP; END; CheckRecipients[]; ReturnDefs.CopyItem[ bodyReader, bodyLength, FTPDefs.FTPSendBlockOfMessage, ftpUser]; FTPDefs.FTPSendBlockOfMessage[ftpUser, NIL, 0]; --end of message-- CheckRecipients[]; FTPDefs.FTPEndDeliveryOfMessage[ftpUser]; EXITS tempFailure => outcome ¬ tempFailure; totalFailure => BEGIN recipient: BodyDefs.RName = [BodyDefs.maxRNameLength]; ended: BOOLEAN; HeapDefs.SetReaderOffset[ SLobj, HeapDefs.objectStart + SIZE[SLDefs.SLHeader]]; IF badList # NIL THEN { HeapDefs.HeapAbandonWrite[badList]; badList ¬ NIL}; IF wrongList # NIL THEN { HeapDefs.HeapAbandonWrite[wrongList]; wrongList ¬ NIL}; badCount ¬ wrongCount ¬ goodCount ¬ 0; [ended, ] ¬ HeapDefs.HeapReadData[SLobj, [recipient, 0]]; UNTIL ended DO ended ¬ HeapDefs.HeapReadRName[SLobj, recipient]; MakeBad[recipient]; ENDLOOP; outcome ¬ totalFailure; END; nobody => BEGIN badCount ¬ badCount + goodCount; goodCount ¬ 0; END; END; FTPDefs.FTPCloseConnection[ftpUser]; LogForwarding[ outcome, host, slHeader.created, goodCount, badCount, wrongCount]; SELECT outcome FROM ok, bad, totalFailure => BEGIN IF badList # NIL THEN ReturnDefs.RejectedByMTP[badList, body, host, badString]; IF wrongList # NIL THEN SLDefs.SLWrite[body, wrongList, pending]; SLDefs.SLEndRead[SLhandle]; END; tempFailure => BEGIN IF badList # NIL THEN HeapDefs.HeapAbandonWrite[badList]; IF wrongList # NIL THEN HeapDefs.HeapAbandonWrite[wrongList]; SLDefs.SLTransfer[SLhandle, input]; ServerDefs.DownServer[slHeader.server]; END; ENDCASE => ERROR; IF badString # NIL THEN Storage.FreeString[badString]; HeapDefs.HeapEndRead[bodyReader]; HeapDefs.HeapEndRead[SLobj]; END; LogForwarding: PROC [ outcome: ForwardOutcome, host: STRING, postmark: BodyDefs.Timestamp, goodCount, badCount, wrongCount: CARDINAL] = BEGIN log: STRING = [140]; log.length ¬ 0; String.AppendString[log, "Forwarded "L]; ProtocolDefs.AppendTimestamp[log, postmark]; String.AppendString[log, " to "L]; String.AppendString[log, host]; String.AppendString[log, ": "]; SELECT outcome FROM ok, bad, totalFailure => BEGIN String.AppendString[log, "good="L]; String.AppendDecimal[log, goodCount]; IF badCount # 0 THEN BEGIN String.AppendString[log, ", bad="L]; String.AppendDecimal[log, badCount]; END; IF wrongCount # 0 THEN BEGIN String.AppendString[log, ", wrong="L]; String.AppendDecimal[log, wrongCount]; END; END; tempFailure => BEGIN String.AppendString[log, "failed temporarily"L]; END; ENDCASE => ERROR; LogDefs.WriteLogEntry[log]; END; NoRecipients: ERROR = CODE; --not caught; should not occur-- NotForeignSite: ERROR = CODE; --not caught; should not occur-- BadForeignSite: ERROR = CODE; --not caught; should not occur-- ForwardMain: PROCEDURE = BEGIN -- multiple instantiations of this procedure are allowed -- DO SLobj: HeapDefs.ReaderHandle ¬ NIL; SLhandle: SLDefs.SLReadHandle; bodyObj: HeapDefs.ObjectNumber; slHeader: SLDefs.SLHeader; [SLhandle, bodyObj, SLobj] ¬ SLDefs.SLStartRead[foreign]; PolicyDefs.WaitOperation[readForward]; BEGIN -- read SL header -- ended: BOOLEAN; used: CARDINAL; [ended, used] ¬ HeapDefs.HeapReadData[ SLobj, [@slHeader, SIZE[SLDefs.SLHeader]]]; IF ended THEN ERROR NoRecipients[]; END; IF slHeader.server.type # foreign THEN ERROR NotForeignSite[]; WITH slHeader.server.name SELECT FROM connect => ForwardMessage[ host: value, SLhandle: SLhandle, SLobj: SLobj, body: bodyObj, slHeader: @slHeader]; ENDCASE => ERROR BadForeignSite[]; -- reader was closed by ForwardMessage -- PolicyDefs.EndOperation[readForward]; ENDLOOP; END; ForwardRestart: PROCEDURE = BEGIN -- on restart, must transfer everything to input, since ServerHandles -- are no longer valid -- THROUGH [1..SLDefs.GetCount[foreign]] DO BEGIN handle: SLDefs.SLReadHandle; body: HeapDefs.ObjectNumber; SL: HeapDefs.ReaderHandle; [handle, body, SL] ¬ SLDefs.SLStartRead[foreign]; HeapDefs.HeapEndRead[SL]; SLDefs.SLTransfer[handle, input]; END; ENDLOOP; END; -- Backstop and Filter for listeners -- Backstop: FTPDefs.BackstopServer ¬ BEGIN addr: PupDefs.PupAddress; IF NOT PupDefs.ParsePupAddressConstant[@addr, originOfRequest] THEN BEGIN addr.net ¬ [0]; addr.host ¬ [0]; END; localInsignia.length ¬ 0; String.AppendString[localInsignia, "Grapevine MTP server "L]; String.AppendString[localInsignia, LocalNameDefs.ReadMSName[].name]; server[ ! FTPDefs.FTPError => SELECT ftpError FROM IN FTPDefs.CommunicationError, IN FTPDefs.ProtocolError => CONTINUE; IN FTPDefs.UnidentifiedError => CONTINUE; ENDCASE => RESUME ; WhoIsHe => RESUME [addr.net, addr.host]]; PolicyDefs.EndOperation[MTP]; END; Filter: PROCEDURE [from: STRING, purpose: FTPDefs.Purpose] = BEGIN IF NOT PolicyDefs.CheckOperation[MTP] THEN BEGIN LogDefs.WriteLogEntry["Rejected MTP connection"L]; ERROR FTPDefs.RejectThisConnection["Server full"L]; END; END; -- Initialization -- InitMTPServer1: PUBLIC PROCEDURE = BEGIN FTPDefs.FTPInitialize[]; FTPDefs.FTPCatchUnidentifiedErrors[FALSE]; ForwardRestart[]; Process.Detach[FORK ForwardMain[]]; END; InitMTPServer2: PUBLIC PROCEDURE = BEGIN [] ¬ FTPDefs.FTPCreateListener[ --purpose-- mail, --DL kludge-- @myDLPrimitives, --mail system-- @myMailPrimitives, --comm system-- FTPDefs.PupCommunicationPrimitives[], --backstop-- @Backstop, --backstopData-- 0, --filter-- Filter]; END; END.