-- Copyright (C) 1981, 1982, 1983, 1984, 1985  by Xerox Corporation. All rights reserved. 
-- ReturnMail.mesa, Transport Mechanism Mail Server - Return Undeliverable Mail --

-- HGM, 15-Sep-85  3:41:57
-- Randy Gobbel		19-May-81 23:38:50 --
-- Andrew Birrell	 4-Mar-82 14:42:33 --
-- Michael Schroeder	25-Jan-83 15:54:32 --

DIRECTORY
  Ascii USING [CR],
  BodyDefs USING [ItemHeader, ItemLength, maxRNameLength, RName, Timestamp],
  Heap USING [systemZone],
  HeapDefs USING [
    GetReaderOffset, HeapAbandonWrite, HeapEndRead, HeapEndWrite, HeapReadData,
    HeapReadRName, HeapStartRead, ObjectNumber, ObjectOffset, objectStart,
    ReaderHandle, SetReaderOffset, WriterHandle],
  Inline USING [LowHalf],
  LocalNameDefs USING [ReadMSName],
  LogDefs USING [ShowLine],
  NameInfoDefs USING [IsMemberDirect, Membership],
  ProtocolDefs USING [AppendTimestamp],
  ReturnDefs USING [],
  SendDefs USING [
    Abort, AddRecipient, AddToItem, Create, Destroy, CheckValidity, Handle,
    StartSend, StartText, Send],
  String USING [AppendChar, AppendDecimal, AppendNumber, AppendString],
  Time USING [Append, Current, Packed, Unpack],
  VMDefs USING [AllocatePage, Page, pageSize, Release];

ReturnMail: PROGRAM
  IMPORTS
    Heap, HeapDefs, Inline, LocalNameDefs, LogDefs, NameInfoDefs, ProtocolDefs,
    SendDefs, String, Time, VMDefs
  EXPORTS ReturnDefs =

  BEGIN

  ParseBody: PUBLIC PROCEDURE [
    reader: HeapDefs.ReaderHandle, stamp: POINTER TO BodyDefs.Timestamp ¬ NIL,
    sender: BodyDefs.RName ¬ NIL, returnTo: BodyDefs.RName ¬ NIL]
    RETURNS [BodyDefs.ItemLength] =
    BEGIN
    textStart: HeapDefs.ObjectOffset;
    textFound: BOOLEAN ¬ FALSE;
    textLength: BodyDefs.ItemLength;
    header: BodyDefs.ItemHeader;
    found: CARDINAL ¬ 0;
    UNTIL found = 4  -- postmark, sender, returnto, text/end --
      DO
      [] ¬ HeapDefs.HeapReadData[reader, [@header, SIZE[BodyDefs.ItemHeader]]];
      BEGIN
      itemStart: HeapDefs.ObjectOffset = HeapDefs.GetReaderOffset[reader];
      found ¬ found + 1;
      SELECT header.type FROM
        PostMark =>
          IF stamp # NIL THEN
            [] ¬ HeapDefs.HeapReadData[reader, [stamp, SIZE[BodyDefs.Timestamp]]];
        Sender =>
          IF sender # NIL THEN [] ¬ HeapDefs.HeapReadRName[reader, sender];
        ReturnTo =>
          IF returnTo # NIL THEN [] ¬ HeapDefs.HeapReadRName[reader, returnTo];
        Text =>
          BEGIN
          textStart ¬ itemStart;
          textLength ¬ header.length;
          textFound ¬ TRUE;
          EXIT
          END;
        LastItem => NULL;
        ENDCASE => found ¬ found - 1;
      --skip past item--
      HeapDefs.SetReaderOffset[reader, itemStart + (1 + header.length) / 2];
      END
      ENDLOOP --each item of a message-- ;
    IF textFound THEN
      BEGIN HeapDefs.SetReaderOffset[reader, textStart]; RETURN[textLength] END
    ELSE RETURN[0]
    END;

  CopyItem: PUBLIC PROCEDURE [
    reader: HeapDefs.ReaderHandle, length: BodyDefs.ItemLength,
    sendBlock: PROCEDURE [SendDefs.Handle, LONG POINTER, CARDINAL],
    sendBlockData: SendDefs.Handle] =
    BEGIN
    data: VMDefs.Page = VMDefs.AllocatePage[];
    WHILE length > 0 DO
      BEGIN
      ENABLE UNWIND => VMDefs.Release[data];
      --messy because we're reading words and sending bytes--
      wanted: CARDINAL;
      given: CARDINAL;
      used: CARDINAL;
      wanted ¬
        IF VMDefs.pageSize * 2 < length THEN VMDefs.pageSize * 2
        ELSE Inline.LowHalf[length];
      [, used] ¬ HeapDefs.HeapReadData[reader, [data, (1 + wanted) / 2]];
      given ¬ MIN[used * 2, wanted];
      sendBlock[sendBlockData, data, given];
      length ¬ length - given;
      END;
      ENDLOOP;
    VMDefs.Release[data];
    END;

  AppendOwner: PROC [s: LONG STRING, group: LONG STRING] =
    BEGIN
    String.AppendString[s, "Owners-"L];
    FOR i: CARDINAL IN [0..MIN[s.maxlength - s.length, group.length]) DO
      s[s.length] ¬ group[i]; s.length ¬ s.length + 1; ENDLOOP;
    END;



  BadRecipients: PUBLIC PROC [
    list: HeapDefs.WriterHandle, body: HeapDefs.ObjectNumber] = {
    Return[list, body, user, NIL, NIL, NIL]};

  BadGroup: PUBLIC PROC [
    list: HeapDefs.WriterHandle, body: HeapDefs.ObjectNumber,
    group: BodyDefs.RName] = {Return[list, body, owner, group, NIL, NIL]};

  LongTerm: PUBLIC PROC [
    list: HeapDefs.WriterHandle, body: HeapDefs.ObjectNumber] = {
    Return[list, body, longTerm, NIL, NIL, NIL]};


  NoDeadLetterRName: SIGNAL = CODE;
  LooksLikeImDown: ERROR = CODE;
  MyNameIsWrong: ERROR = CODE;
  maxReturnDays: CARDINAL = 7;  -- discard messages older than this --

  Return: PROCEDURE [
    list: HeapDefs.WriterHandle, body: HeapDefs.ObjectNumber,
    case: {user, owner, longTerm}, group: BodyDefs.RName,
    server, text: LONG STRING] =
    BEGIN OPEN SendDefs;
    bodyReader: HeapDefs.ReaderHandle = HeapDefs.HeapStartRead[body];
    sendHandle: Handle = Create[];
    wsBuffer: STRING = [64];
    ws: PROCEDURE [s: LONG STRING] =
      BEGIN OPEN Ascii;
      FOR index: CARDINAL IN [0..s.length) DO
        IF wsBuffer.length = wsBuffer.maxlength  --must be even--
          THEN
          BEGIN
          AddToItem[sendHandle, DESCRIPTOR[@(wsBuffer.text), wsBuffer.length]];
          wsBuffer.length ¬ 0;
          END;
        wsBuffer[wsBuffer.length] ¬ IF s[index] = '~ THEN CR ELSE s[index];
        wsBuffer.length ¬ wsBuffer.length + 1;
        ENDLOOP;
      END;
    FlushWS: PROC =
      BEGIN
      IF wsBuffer.length MOD 2 # 0 THEN ws[" "L];
      AddToItem[sendHandle, DESCRIPTOR[@(wsBuffer.text), wsBuffer.length]];
      wsBuffer.length ¬ 0;
      END;
    wt: PROCEDURE [t: Time.Packed] =
      BEGIN s: STRING = [30]; Time.Append[s, Time.Unpack[t], TRUE]; ws[s]; END;
    textLength: BodyDefs.ItemLength;
    badCount: CARDINAL ¬ 0;
    stamp: BodyDefs.Timestamp;
    returnTo: BodyDefs.RName = [BodyDefs.maxRNameLength];
    sender: BodyDefs.RName = [BodyDefs.maxRNameLength];
    textLength ¬ ParseBody[
      bodyReader, @stamp, sender, IF case = owner THEN NIL ELSE returnTo];
    IF stamp.time + maxReturnDays * 24 * LONG[60 * 60] < Time.Current[] THEN
      BEGIN HeapDefs.HeapAbandonWrite[list]; LogDiscard[stamp, sender]; END
    ELSE
      BEGIN
      textStart: HeapDefs.ObjectOffset = HeapDefs.GetReaderOffset[bodyReader];
      myName: BodyDefs.RName;
      password: LONG STRING;
      dead: BodyDefs.RName = "DeadLetter.MS"L;
      badReader: HeapDefs.ReaderHandle;
      Start: PROC [validate: BOOLEAN] =
        BEGIN
        SELECT StartSend[
        handle: sendHandle, sender: myName, senderPwd: password, returnTo: dead,
        validate: validate] FROM
          ok => NULL;
          badReturnTo => ERROR NoDeadLetterRName[];
          badSender, badPwd => ERROR MyNameIsWrong[];
          allDown => ERROR LooksLikeImDown[] --silly: I'm not down!-- ;
          ENDCASE => ERROR;
        END;
      [myName, password, ] ¬ LocalNameDefs.ReadMSName[];
      IF case = owner THEN AppendOwner[returnTo, group];
      Start[TRUE];
      AddRecipient[sendHandle, returnTo];
      BEGIN
      bad: BOOLEAN ¬ FALSE;
      Notify: PROCEDURE [number: CARDINAL, who: LONG STRING] = BEGIN bad ¬ TRUE; END;
      [] ¬ CheckValidity[sendHandle, Notify];
      IF bad THEN
        BEGIN
        Abort[sendHandle];
        returnTo.length ¬ 0;
        String.AppendString[returnTo, dead];
        Start[TRUE];
        AddRecipient[sendHandle, returnTo];
        bad ¬ FALSE;
        [] ¬ CheckValidity[sendHandle, Notify];
        IF bad THEN ERROR NoDeadLetterRName[];
        END;
      END;
      StartText[sendHandle];
      ws["Subject: Undelivered mail~From: "L];
      ws[myName];
      ws[" (a Grapevine mail server)~To: "L];
      ws[returnTo];
      ws["~Date: "L];
      wt[Time.Current[]];
      ws["~~The message sent by "L];
      ws[sender];
      ws[" at "L];
      wt[LOOPHOLE[stamp.time]];
      ws[" could not be delivered to the following recipients "L];
      SELECT case FROM
        user => ws["because their names are invalid."L];
        owner =>
          BEGIN
          ws["because they are invalid names in the distribution list """L];
          ws[group];
          ws[""".  Please remove them from that list."L];
          END;
        longTerm =>
          ws[
            "within a reasonable time, because of network failures or the unavailability of other servers."L];
        ENDCASE => ERROR;
      ws["~~"L];
      BEGIN
      name: BodyDefs.RName = [BodyDefs.maxRNameLength];
      ended: BOOLEAN;
      GetReader: PROCEDURE [obj: HeapDefs.ObjectNumber] =
        BEGIN badReader ¬ HeapDefs.HeapStartRead[obj]; END;
      HeapDefs.HeapEndWrite[list, GetReader];
      [ended] ¬ HeapDefs.HeapReadData[badReader, [name, 0]];
      UNTIL ended DO
        ended ¬ HeapDefs.HeapReadRName[badReader, name];
        badCount ¬ badCount + 1;
        ws[name];
        IF NOT ended THEN ws[", "L];
        ENDLOOP;
      END;
      ws["~~"L];
      IF case = owner THEN FlushWS[]
      ELSE
        BEGIN
        IF textLength > 0 THEN
          BEGIN
          SillySend: PROCEDURE [u: SendDefs.Handle, p: LONG POINTER, c: CARDINAL] = {
            AddToItem[u, DESCRIPTOR[p, c]]};
          ws["----------------~~"L];
          IF wsBuffer.length MOD 2 # 0 THEN ws["~"L];
          FlushWS[];
          CopyItem[bodyReader, textLength, SillySend, sendHandle];
          END
        ELSE {ws["There was no message text."L]; FlushWS[]};
        END;
      LogReturn[stamp, returnTo, badCount];
      Send[sendHandle];
      BEGIN
      who: LONG STRING ¬ "GGWMsgs^.MS";
      IF case # user OR Filter[stamp] THEN who ¬ dead;
      Start[FALSE];
      AddRecipient[sendHandle, who];
      StartText[sendHandle];
      ws["Subject: Undelivered mail notification~From: "L];
      ws[myName];
      ws["~To: "L];
      ws[who];
      ws["~Date: "L];
      wt[Time.Current[]];
      ws["~~Reason: "L];
      ws[
        SELECT case FROM
          user => "Invalid recipients(s)"L,
          owner => "Invalid recipients(s) in DL"L,
          longTerm => "Message time-out"L,
          ENDCASE => ERROR];
      ws["~Notification sent to: "L];
      ws[returnTo];
      ws["~Original postmark: "L];
      wt[LOOPHOLE[stamp.time]];
      ws[" = "L];
      {
      s: STRING = [18]; ProtocolDefs.AppendTimestamp[s, stamp]; ws[s]};
      ws["~Sender: "L];
      ws[sender];
      SELECT case FROM
        user => NULL;
        owner => {ws["~Group: "L]; ws[group]};
        longTerm => NULL;
        ENDCASE => ERROR;
      ws["~Undeliverable recipient(s): "L];
      HeapDefs.SetReaderOffset[badReader, HeapDefs.objectStart];
      FOR i: CARDINAL IN [1..badCount] DO
        name: BodyDefs.RName = [BodyDefs.maxRNameLength];
        IF i # 1 THEN ws[", "L];
        [] ¬ HeapDefs.HeapReadRName[badReader, name];
        ws[name];
        ENDLOOP;
      IF textLength > 0 THEN
        BEGIN
        length: BodyDefs.ItemLength ¬ textLength;
        crSeen: BOOLEAN ¬ FALSE;  -- end on double CR --
        ws["~Text header:~~"L];
        HeapDefs.SetReaderOffset[bodyReader, textStart];
        WHILE length > 0 DO
          buff: STRING = [64];
          wanted: CARDINAL =
            IF buff.maxlength < length THEN buff.maxlength
            ELSE Inline.LowHalf[length];
          [] ¬ HeapDefs.HeapReadData[bodyReader, [@buff.text, (wanted + 1) / 2]];
          length ¬ length - wanted;
          buff.length ¬ wanted;
          FOR i: CARDINAL IN [0..buff.length) DO
            IF buff[i] = Ascii.CR THEN {
              IF crSeen THEN {buff.length ¬ i; ws[buff]; GOTO ended}
              ELSE crSeen ¬ TRUE}
            ELSE crSeen ¬ FALSE;
            ENDLOOP;
          ws[buff];
          REPEAT ended => NULL;
          ENDLOOP;
        END
      ELSE ws["~No text~"L];
      FlushWS[];
      Send[sendHandle];
      END;
      HeapDefs.HeapEndRead[badReader];
      END;
    HeapDefs.HeapEndRead[bodyReader];
    Destroy[sendHandle];
    END;

  -- Hack to filter out crap because GGW injects invalid recipients
  Filter: PROC [stamp: BodyDefs.Timestamp] RETURNS [go: BOOLEAN] =
    BEGIN
    group: BodyDefs.RName = "GGWFilter^.MS"L;
    source: STRING = [8];
    m: NameInfoDefs.Membership;
    String.AppendNumber[source, stamp.net, 8];
    String.AppendChar[source, '#];
    String.AppendNumber[source, stamp.host, 8];
    String.AppendChar[source, '#];
    m ¬ NameInfoDefs.IsMemberDirect[group, source];
    IF m = yes THEN RETURN[FALSE];
    RETURN[TRUE];
    END;

  LogDiscard: PROC [stamp: BodyDefs.Timestamp, sender: BodyDefs.RName] =
    BEGIN
    len: CARDINAL = sender.length;
    log: LONG STRING ¬ Heap.systemZone.NEW[StringBody[128]];
    String.AppendString[log, "Discarded old "L];
    ProtocolDefs.AppendTimestamp[log, stamp];
    String.AppendString[log, " Sender="L];
    sender.length ¬ MIN[len, log.maxlength - log.length];
    String.AppendString[log, sender];
    sender.length ¬ len;
    LogDefs.ShowLine[log];
    Heap.systemZone.FREE[@log];
    END;

  LogReturn: PROC [
    stamp: BodyDefs.Timestamp, returnTo: BodyDefs.RName, badCount: CARDINAL] =
    BEGIN
    len: CARDINAL = returnTo.length;
    log: LONG STRING ¬ Heap.systemZone.NEW[StringBody[128]];
    String.AppendString[log, "Returned "L];
    ProtocolDefs.AppendTimestamp[log, stamp];
    String.AppendString[log, " to "L];
    returnTo.length ¬ MIN[len, log.maxlength - log.length - 10];
    String.AppendString[log, returnTo];
    returnTo.length ¬ len;
    String.AppendString[log, ": "L];
    String.AppendDecimal[log, badCount];
    String.AppendString[log, " bad"L];
    LogDefs.ShowLine[log];
    Heap.systemZone.FREE[@log];
    END;

  END.