-- Copyright (C) 1981, 1982, 1983, 1984, 1985  by Xerox Corporation. All rights reserved. 
-- RegMail.mesa, Transport Mechanism Registration Server - Internal Mail.

-- HGM, 15-Sep-85 11:50:42 
-- Randy Gobbel,	19-May-81 12:26:40 
-- Andrew Birrell,	18-Nov-82 10:33:12
-- Mike Schroeder	  8-Feb-83  9:43:22 
-- Hankins		14-Aug-84 16:30:13	(Klamath update - remove STOPs)

DIRECTORY
  BodyDefs USING [
    ItemHeader, ItemLength, ItemType, maxRNameLength, oldestTime, Password, RName,
    RNameSize, Timestamp],
  EnquiryDefs USING [],
  Heap USING [systemZone],
  HeapDefs USING [
    HeapEndWrite, HeapEndRead, HeapReadData, HeapStartWrite, HeapWriteData,
    ObjectNumber, ReaderHandle, WriterHandle],
  LocalNameDefs USING [ReadRSName],
  LogDefs USING [WriteLogEntry],
  ObjectDirDefs USING [FreeObject, noObject],
  PolicyDefs USING [CheckOperation, EndOperation, Wait, WaitOperation],
  Process USING [Detach, DisableTimeout],
  ProtocolDefs USING [AppendTimestamp, ReturnCode, RSOperation],
  RegBTreeDefs USING [Lookup, LookupReason, RegistryObject],
  RegServerDefs USING [IsMember, ReadRegistryMembers, Update, UpdateSublist],
  RegistryDefs USING [EnumerateRList],
  RetrieveDefs USING [
    AccessProcs, Failed, Handle, Create, MailboxState, NewUser, NextServer,
    ServerName, ServerState, WaitForMail],
  SendDefs USING [
    Abort, AddRecipient, AddToItem, Create, Destroy, Handle, StartItem, StartSend,
    Send],
  String USING [AppendString, EquivalentString],
  VMDefs USING [AllocatePage, Page, pageSize, Release];

RegMail: MONITOR
  IMPORTS
    BodyDefs, Heap, HeapDefs, LocalNameDefs, LogDefs, ObjectDirDefs, PolicyDefs,
    Process, ProtocolDefs, RegBTreeDefs, RegistryDefs, RegServerDefs,
    RetrieveDefs, SendDefs, String, VMDefs
  EXPORTS EnquiryDefs --LoginRSMail-- , RegServerDefs =

  BEGIN

  OPEN ProtocolDefs;

  -- the update mail is generated in a separate process to allow return to
  -- client sooner, and to avoid deadlock if we generate an update while
  -- determining our R-Server name.

  updateEntry: BodyDefs.RName = [BodyDefs.maxRNameLength];
  updateStamp: BodyDefs.Timestamp;
  updateElement: BodyDefs.RName = [BodyDefs.maxRNameLength];
  updateOp: ProtocolDefs.RSOperation;
  updateRSMailObj: HeapDefs.ObjectNumber;
  updatePending: BOOLEAN ¬ FALSE;
  updateCond: CONDITION;
  updateEnabled: BOOLEAN ¬ FALSE;  -- set TRUE early in restart --

  NoRegistryForName: ERROR = CODE;
  FailedToSendUpdate: ERROR = CODE;


  MailUpdate: PUBLIC ENTRY PROCEDURE [
    entry: BodyDefs.RName, stamp: BodyDefs.Timestamp, element: BodyDefs.RName,
    op: ProtocolDefs.RSOperation, rsMailObj: HeapDefs.ObjectNumber] =
    BEGIN
    IF updateEnabled THEN
      BEGIN
      WHILE updatePending DO WAIT updateCond ENDLOOP;
      updateEntry.length ¬ 0;
      String.AppendString[updateEntry, entry];
      updateStamp ¬ stamp;
      updateElement.length ¬ 0;
      IF element # NIL THEN String.AppendString[updateElement, element];
      updateOp ¬ op;
      updateRSMailObj ¬ rsMailObj;
      updatePending ¬ TRUE;
      NOTIFY updateCond;
      END
    ELSE
      IF rsMailObj # ObjectDirDefs.noObject THEN
        ObjectDirDefs.FreeObject[rsMailObj];
    END;

  SendRSMail: ENTRY PROC =
    BEGIN
    DO
      UNTIL updatePending DO WAIT updateCond ENDLOOP;
      SendUpdate[updateEntry, updateStamp, updateElement, updateOp];
      IF updateRSMailObj # ObjectDirDefs.noObject THEN
        ObjectDirDefs.FreeObject[updateRSMailObj];
      updatePending ¬ FALSE;
      NOTIFY updateCond;
      ENDLOOP;
    END;

  briefUpdate: BodyDefs.ItemType = LOOPHOLE[2001B];
  briefUpdateAllowed: BOOLEAN ¬ TRUE;

  SendUpdate: INTERNAL PROC [
    entry: BodyDefs.RName, stamp: BodyDefs.Timestamp, element: BodyDefs.RName,
    op: ProtocolDefs.RSOperation] =
    BEGIN
    -- mail the object to other registration servers for entry's registry.
    regobj: RegBTreeDefs.RegistryObject = RegBTreeDefs.Lookup[entry, readAny];
    myName: BodyDefs.RName;
    myPassword: LONG STRING;
    [myName, myPassword, ] ¬ LocalNameDefs.ReadRSName[];
    IF regobj.type # notFound THEN
      BEGIN
      message: SendDefs.Handle = SendDefs.Create[];
      itsRegReader: HeapDefs.ReaderHandle = LookupRegistry[entry];
      IF SendDefs.StartSend[
        handle: message, senderPwd: myPassword, sender: myName,
        returnTo: "DeadLetter.MS"L, validate: FALSE] # ok THEN
        ERROR FailedToSendUpdate[];
      IF CopyRList[message, myName, itsRegReader] > 0 THEN
        BEGIN
        humanHint: LONG STRING = "RS internal mail for R-Name "L;
        SELECT op FROM
          AddMember, DeleteMember =>
            IF briefUpdateAllowed THEN
              BriefUpdate[message, entry, stamp, element, op]
            ELSE FullUpdate[message, regobj.reader];
          ENDCASE => FullUpdate[message, regobj.reader];
        HeapDefs.HeapEndRead[regobj.reader];
        -- in case it gets to DeadLetter! --
        SendDefs.StartItem[message, Text];
        SendDefs.AddToItem[
          message, DESCRIPTOR[@(humanHint.text), humanHint.length]];
        SendDefs.AddToItem[message, DESCRIPTOR[@(entry.text), entry.length]];
        SendDefs.Send[message];
        END
      ELSE
        BEGIN  --no recipients--
        SendDefs.Abort[message];
        HeapDefs.HeapEndRead[regobj.reader];
        END;
      SendDefs.Destroy[message];
      END;
    END;

  LookupRegistry: PROCEDURE [name: BodyDefs.RName]
    RETURNS [reader: HeapDefs.ReaderHandle] =
    BEGIN
    oldTimePtr: BodyDefs.Timestamp ¬ BodyDefs.oldestTime;  --ugh!--
    rc: ProtocolDefs.ReturnCode;
    [reader, rc] ¬ RegServerDefs.ReadRegistryMembers[name, @oldTimePtr];
    IF rc.code # done THEN ERROR NoRegistryForName[];
    END;

  CopyRList: PROCEDURE [
    message: SendDefs.Handle, me: BodyDefs.RName, reader: HeapDefs.ReaderHandle]
    RETURNS [recipients: CARDINAL] =
    BEGIN
    Work: PROC [name: BodyDefs.RName] RETURNS [done: BOOLEAN] =
      BEGIN
      done ¬ FALSE;
      IF NOT String.EquivalentString[me, name] THEN
        BEGIN
        SendDefs.AddRecipient[message, name];
        recipients ¬ recipients + 1;
        END;
      END;
    recipients ¬ 0;
    RegistryDefs.EnumerateRList[reader, Work];
    HeapDefs.HeapEndRead[reader];
    END;

  FullUpdate: PROCEDURE [
    message: SendDefs.Handle, reader: HeapDefs.ReaderHandle] =
    BEGIN
    buffer: VMDefs.Page = VMDefs.AllocatePage[];
    BEGIN
    ENABLE UNWIND => VMDefs.Release[buffer];
    ended: BOOLEAN;
    used: CARDINAL;
    SendDefs.StartItem[message, updateItem];
    DO
      [ended, used] ¬ HeapDefs.HeapReadData[reader, [buffer, VMDefs.pageSize]];
      SendDefs.AddToItem[
        message, DESCRIPTOR[LOOPHOLE[buffer, LONG POINTER], 2 * used]];
      IF ended THEN EXIT;
      -- why isn't the error SendDefs.SendFailed recognized in this module?
      ENDLOOP;
    END;
    VMDefs.Release[buffer];
    END;


  BriefUpdate: PROCEDURE [
    message: SendDefs.Handle, entry: BodyDefs.RName, stamp: BodyDefs.Timestamp,
    element: BodyDefs.RName, op: ProtocolDefs.RSOperation] =
    BEGIN
    SendDefs.StartItem[message, briefUpdate];
    SendDefs.AddToItem[
      message, DESCRIPTOR[
      LOOPHOLE[LONG[@op], LONG POINTER], 2 * SIZE[ProtocolDefs.RSOperation]]];
    SendDefs.AddToItem[
      message, DESCRIPTOR[
      LOOPHOLE[entry, LONG POINTER], 2 * BodyDefs.RNameSize[entry]]];
    SendDefs.AddToItem[
      message, DESCRIPTOR[
      LOOPHOLE[element, LONG POINTER], 2 * BodyDefs.RNameSize[element]]];
    SendDefs.AddToItem[
      message, DESCRIPTOR[
      LOOPHOLE[LONG[@stamp], LONG POINTER], 2 * SIZE[BodyDefs.Timestamp]]];
    END;


  -- RS Mail reading --

  handle: RetrieveDefs.Handle = RetrieveDefs.Create[pollingInterval: 30];

  readerActive: BOOLEAN ¬ FALSE;
  readerInactive: CONDITION ¬ [timeout: 0];

  LoginRSMail: PUBLIC ENTRY PROC =
    BEGIN
    myName: BodyDefs.RName;
    myPassword: LONG STRING;
    WHILE readerActive DO WAIT readerInactive ENDLOOP;
    [myName, myPassword, ] ¬ LocalNameDefs.ReadRSName[];
    RetrieveDefs.NewUser[handle: handle, user: myName, password: myPassword];
    DO
      sName: BodyDefs.RName = [BodyDefs.maxRNameLength];
      noMore: BOOLEAN;
      [noMore, , ] ¬ RetrieveDefs.NextServer[handle];
      IF noMore THEN EXIT;
      LogInboxSite["RS inbox-site: "L];
      ENDLOOP;
    END;

  LogInboxSite: INTERNAL PROC [s: LONG STRING] =
    BEGIN
    log: LONG STRING ¬ Heap.systemZone.NEW[StringBody[128]];
    server: STRING = [64];
    RetrieveDefs.ServerName[handle, server];
    String.AppendString[log, s];
    server.length ¬ MIN[server.length, log.maxlength - log.length];
    String.AppendString[log, server];
    LogDefs.WriteLogEntry[log];
    Heap.systemZone.FREE[@log];
    END;

  LockReader: ENTRY PROC = INLINE {readerActive ¬ TRUE};

  UnlockReader: ENTRY PROC = INLINE {readerActive ¬ FALSE; NOTIFY readerInactive};

  MyNameIsBad: ERROR = CODE;
  MyPwdIsBad: ERROR = CODE;

  ReadMail: PUBLIC PROCEDURE =
    BEGIN
    -- Reads outstanding mail before returning --
    LoginRSMail[];
    SELECT RetrieveDefs.MailboxState[handle] FROM
      badName => ERROR MyNameIsBad[];
      badPwd => ERROR MyPwdIsBad[];
      notEmpty =>
        IF PolicyDefs.CheckOperation[RSReadMail] THEN {
          RegMailReader[]; PolicyDefs.EndOperation[RSReadMail]};
      ENDCASE => NULL;
    Process.Detach[FORK RegMailWatcher[]];
    END;

  RegMailWatcher: PROC =
    BEGIN
    DO
      RetrieveDefs.WaitForMail[handle];
      PolicyDefs.WaitOperation[RSReadMail];
      RegMailReader[];
      PolicyDefs.EndOperation[RSReadMail];
      PolicyDefs.Wait[mins: 3];
      ENDLOOP;
    END;

  RegMailReader: PROC =
    BEGIN
    LockReader[];
    DO
      noMore: BOOLEAN;
      state: RetrieveDefs.ServerState;
      gv: RetrieveDefs.AccessProcs;
      [noMore, state, gv] ¬ RetrieveDefs.NextServer[handle];
      IF noMore THEN EXIT;
      IF state # notEmpty THEN LOOP;
      BEGIN
      ENABLE RetrieveDefs.Failed => CONTINUE;
      pleaseFlush: BOOLEAN ¬ TRUE;
      DO
        sender: BodyDefs.RName = [BodyDefs.maxRNameLength];
        time: BodyDefs.Timestamp;
        msgExists, archived, deleted: BOOLEAN;
        pleaseDelete: BOOLEAN ¬ TRUE;
        [msgExists, archived, deleted] ¬ gv.nextMessage[handle];
        IF deleted THEN LOOP;
        IF NOT msgExists THEN EXIT;
        gv.startMessage[handle: handle, sender: sender, postmark: @time];
        IF CheckAndLog[sender, time] THEN
          DO
            header: BodyDefs.ItemHeader = gv.nextItem[handle];
            SELECT header.type FROM
              LastItem => EXIT;
              updateItem => {AcceptUpdate[handle, @gv]; EXIT};
              briefUpdate =>
                BEGIN
                IF NOT AcceptBriefUpdate[handle, header.length, @gv]
                  -- keep only names in a local registry which weren't found
                  THEN pleaseDelete ¬ FALSE;
                EXIT
                END;
              ENDCASE => NULL;
            ENDLOOP --each item-- ;
        IF pleaseDelete THEN gv.deleteMessage[handle] ELSE pleaseFlush ¬ FALSE;
        ENDLOOP --each message-- ;
      IF pleaseFlush THEN gv.accept[handle];
      END;
      ENDLOOP --each server-- ;
    UnlockReader[];
    END;

  CheckAndLog: PROC [sender: BodyDefs.RName, time: BodyDefs.Timestamp]
    RETURNS [good: BOOLEAN] =
    BEGIN
    log: LONG STRING ¬ Heap.systemZone.NEW[StringBody[128]];
    good ¬ TRUE;
    String.AppendString[log, "RS reading "L];
    ProtocolDefs.AppendTimestamp[log, time];
    String.AppendString[log, " from "L];
    String.AppendString[log, sender];
    IF RegServerDefs.IsMember["*.gv"L, sender, direct].membership # yes THEN {
      String.AppendString[log, ": bad sender"L]; good ¬ FALSE};
    LogDefs.WriteLogEntry[log];
    Heap.systemZone.FREE[@log];
    END;

  GetMsgItem: PROCEDURE [
    handle: RetrieveDefs.Handle, gv: POINTER TO RetrieveDefs.AccessProcs]
    RETURNS [writer: HeapDefs.WriterHandle] =
    BEGIN
    buffer: VMDefs.Page = VMDefs.AllocatePage[];
    BEGIN
    ENABLE UNWIND => VMDefs.Release[buffer];
    length: CARDINAL;
    writer ¬ HeapDefs.HeapStartWrite[temp];
    WHILE (length ¬ gv.nextBlock[handle, DESCRIPTOR[buffer, 2 * VMDefs.pageSize]])
      > 0 DO HeapDefs.HeapWriteData[writer, [buffer, (1 + length) / 2]]; ENDLOOP;
    END;
    VMDefs.Release[buffer];
    END;

  MangledMessage: ERROR = CODE;

  AcceptUpdate: PROCEDURE [
    handle: RetrieveDefs.Handle, gv: POINTER TO RetrieveDefs.AccessProcs] =
    BEGIN
    updateWriter: HeapDefs.WriterHandle = GetMsgItem[handle, gv];
    AcceptRestOfMessage[handle, gv];
    HeapDefs.HeapEndWrite[updateWriter, RegServerDefs.Update];
    END;  --AcceptUpdate--


  AcceptBriefUpdate: PROCEDURE [
    handle: RetrieveDefs.Handle, itemLength: BodyDefs.ItemLength,
    gv: POINTER TO RetrieveDefs.AccessProcs] RETURNS [ok: BOOLEAN] =
    BEGIN
    strHeader: CARDINAL = 2 * SIZE[StringBody [0]];
    op: ProtocolDefs.RSOperation;
    entry: BodyDefs.RName = [BodyDefs.maxRNameLength];
    element: BodyDefs.RName = [BodyDefs.maxRNameLength];
    stamp: BodyDefs.Timestamp;
    rc: ProtocolDefs.ReturnCode;
    regLocal: BOOLEAN;
    length: CARDINAL;
    length ¬ gv.nextBlock[
      handle, DESCRIPTOR[
      LOOPHOLE[LONG[@op], LONG POINTER], 2 * SIZE[ProtocolDefs.RSOperation]]];
    itemLength ¬ itemLength - length;
    length ¬ gv.nextBlock[
      handle, DESCRIPTOR[LOOPHOLE[entry, LONG POINTER], strHeader]];
    itemLength ¬ itemLength - length;
    length ¬ gv.nextBlock[
      handle, DESCRIPTOR[
      LOOPHOLE[@entry.text, LONG POINTER], 2 * BodyDefs.RNameSize[entry] - strHeader]];
    itemLength ¬ itemLength - length;
    length ¬ gv.nextBlock[
      handle, DESCRIPTOR[LOOPHOLE[element, LONG POINTER], strHeader]];
    itemLength ¬ itemLength - length;
    length ¬ gv.nextBlock[
      handle, DESCRIPTOR[
      LOOPHOLE[@element.text, LONG POINTER], 2 * BodyDefs.RNameSize[element] - strHeader]];
    itemLength ¬ itemLength - length;
    length ¬ gv.nextBlock[
      handle, DESCRIPTOR[
      LOOPHOLE[LONG[@stamp], LONG POINTER], 2 * SIZE[BodyDefs.Timestamp]]];
    itemLength ¬ itemLength - length;
    IF itemLength # 0 OR length # 2 * SIZE[BodyDefs.Timestamp] THEN
      ERROR MangledMessage[];
    AcceptRestOfMessage[handle, gv];
    [rc, regLocal] ¬ RegServerDefs.UpdateSublist[entry, element, op, stamp];
    RETURN[rc.type # notFound AND regLocal]
    END;

  AcceptRestOfMessage: PROCEDURE [
    handle: RetrieveDefs.Handle, gv: POINTER TO RetrieveDefs.AccessProcs] =
    BEGIN
    DO
      header: BodyDefs.ItemHeader = gv.nextItem[handle];
      SELECT header.type FROM LastItem => EXIT; ENDCASE => NULL;
      ENDLOOP;
    END;  --AcceptRestOfMessage--

  RegMailInit: PUBLIC PROCEDURE = {
    Process.DisableTimeout[@updateCond]; Process.Detach[FORK SendRSMail[]]};

  RegMailEnableUpdates: PUBLIC ENTRY PROCEDURE = {updateEnabled ¬ TRUE};


  END.