-- File:  AnswerImpl.Mesa
-- based on [Juniper]<DMS>Laurel>6T30>IntAnswerCom.mesa
-- edited by Karlton, Friday Feb. 13, 1981 6:10 pm PST
-- edited by Levin,   4-Mar-81 10:23:39

DIRECTORY
  Answer USING [Block],
  Ascii USING [CR, SP],
  Inline USING [LongCOPY],
  MailParse USING [
    endOfInput, FinalizeParse, GetFieldBody, GetFieldName, InitializeParse,
    maxFieldNameSize,  maxRecipientLength, NameInfo, ParseError, ParseHandle,
    ParseNameList],
  Storage USING [Free, FreeString, Node, String],
  String USING [AppendChar, AppendString, EquivalentString, LowerCase];
  
AnswerImpl: PROGRAM
  IMPORTS Inline, MailParse, String, Storage EXPORTS Answer =
  
  BEGIN
  
  -- Local Data Structures and Types
  
  Buffer: TYPE = LONG STRING;
  CharIndex: TYPE = CARDINAL;
  nullIndex: CharIndex = LAST[CharIndex];
  
  Name: TYPE = POINTER TO NameRecord;
  NameRecord: TYPE = RECORD [simpleName, registry, arpaHost: STRING];
  
  Qualification: TYPE = {unqualified, dotQualified, arpaQualified};
  
  DuplicateNameHandle: TYPE = POINTER TO DuplicateName;
  DuplicateName: TYPE = RECORD [
    next: DuplicateNameHandle, seenOnSecondPass: BOOLEAN, name: STRING];
  
  -- Exported Procedures
  
  MakeHeader: PUBLIC PROCEDURE [
    getChar: PROCEDURE [CARDINAL] RETURNS [CHARACTER], getLength: CARDINAL,
    putBlock: PROCEDURE [Answer.Block],
    getPages: PROCEDURE [CARDINAL] RETURNS [LONG POINTER],
    freePages: PROCEDURE [LONG POINTER],
    userName, userRegistry: STRING,
    arpaGatewayHostNames: DESCRIPTOR FOR ARRAY OF STRING,
    cForCopies: BOOLEAN _ FALSE]
    RETURNS [answerError: BOOLEAN] =
    BEGIN
    getCharIndex, reStart: CharIndex;
    pH: MailParse.ParseHandle;
    havePH: BOOLEAN _ FALSE;
    buffer: Buffer _ NIL;
    idIndex: CharIndex _ nullIndex;
    dateIndex: CharIndex _ nullIndex;
    subjectIndex: CharIndex _ nullIndex;
    
    nameSize: CARDINAL = 60;
    
    PutIndex: TYPE = {subject, inreply, to, cc}; -- order is significant!
    FieldIndex: TYPE = {
      id, reply, sender, from, to, cc, c, bcc, date, subject}; -- order is significant!
    knownField: ARRAY FieldIndex OF STRING =
      ["Message-ID"L, "Reply-to"L, "Sender"L, "From"L, "To"L, "cc"L, "c"L, "bcc"L,
	"Date"L, "Subject"L]; -- order corresponds to FieldIndex
    answerTarget: FieldIndex _ SUCC[from];
    
    originSN: STRING = [MailParse.maxRecipientLength];
    originReg: STRING = [MailParse.maxRecipientLength];
    originH: STRING = [MailParse.maxRecipientLength];
    originPieces: NameRecord _ [originSN, originReg, originH];
    originName: Name = @originPieces;
    originQual: Qualification;
    originIndex: FieldIndex _ reply; -- anything except sender or from
    answerTargetBodyCharIndex: CharIndex _ 0;
    
    defaultRegistry: STRING = "PA"L;
    replyerRegIsDefault: BOOLEAN = String.EquivalentString[userRegistry, defaultRegistry];
    targetEqualsOrigin: BOOLEAN _ TRUE;
    
    namesOutput: BOOLEAN _ FALSE;
    replyerCCed: BOOLEAN _ FALSE;
    ccCount: CARDINAL _ 0;
    DuplicateHead: DuplicateNameHandle _ NIL;
    
    AppendToBuffer: PROCEDURE [b: POINTER TO Buffer, char: CHARACTER] =
      BEGIN
      IF b.length >= b.maxlength THEN {
	pages: CARDINAL = ((b.maxlength + 4)/512) + 1;
	temp: Buffer _ NewBuffer[pages];
	Inline.LongCOPY[from: @b.text, to: @temp.text, nwords: b.maxlength/2];
	temp.length _ b.length;
	freePages[b^];
	b^ _ temp};
      b[b.length] _ char;
      b.length _ b.length + 1;
      RETURN
      END; -- of AppendToBuffer --
      
    AppendStringToBuffer: PROCEDURE [b: POINTER TO Buffer, s: STRING] =
      BEGIN
      IF s # NIL THEN FOR i: CARDINAL IN [0..s.length) DO
	AppendToBuffer[b, s[i]] ENDLOOP;
      END; -- of AppendStringToBuffer --
      
    DeleteRangeInBuffer: PROCEDURE [b: Buffer, from, to: CARDINAL] =
      BEGIN
      dif: CARDINAL = to - from;
      b.length _ b.length - dif;
      FOR i: CARDINAL IN [from..b.length) DO b[i] _ b[i+dif] ENDLOOP;
      END; -- of DeleteRangeInBuffer --
      
    NewBuffer: PROCEDURE [pages: CARDINAL] RETURNS [b: Buffer] =
      BEGIN
      b _ getPages[pages];
      b^ _ [length: 0, maxlength: pages*512 - 4, text: ];
      END; -- of NewBuffer --
      
    GetNextChar: PROCEDURE RETURNS [char: CHARACTER] =
      BEGIN
      char _
	IF getCharIndex >= getLength THEN MailParse.endOfInput ELSE getChar[getCharIndex];
      getCharIndex _ getCharIndex + 1;
      END; -- of GetNextChar --
      
    BackupChar: PROCEDURE = {getCharIndex _ getCharIndex - 1};
    
    InitParse: PROCEDURE = {
	pH _ MailParse.InitializeParse[GetNextChar, BackupChar]; havePH _ TRUE};

    FinParse: PROCEDURE = {MailParse.FinalizeParse[pH]; havePH _ FALSE};

    StuffChar: PROCEDURE [char: CHARACTER] =
      BEGIN
      IF char ~= Ascii.CR THEN [] _ AppendToBuffer[@buffer, char];
      END; -- of StuffChar --
      
    ProcessFields: PROCEDURE [Inner: PROC [index: FieldIndex]] =
      BEGIN OPEN MailParse;
      discardS: STRING = [0];
      fieldName: STRING = [maxFieldNameSize];
      getCharIndex _ 0;
      InitParse[];
      DO
	IF ~GetFieldName[pH, fieldName] THEN EXIT;
	FOR i: FieldIndex IN FieldIndex DO
	  IF String.EquivalentString[fieldName, knownField[i]] THEN {Inner[i]; EXIT};
	  REPEAT FINISHED => GetFieldBody[pH, discardS];
	  ENDLOOP;
	ENDLOOP;
      FinParse[];
      END; -- of ProcessFields --
      
    DetermineQualification: PROCEDURE [name: Name] RETURNS [Qualification] =
      BEGIN
      RETURN[
	SELECT TRUE FROM
	  name.arpaHost.length > 0 => arpaQualified,
	  name.registry.length > 0 => dotQualified,
	  ENDCASE => unqualified]
      END; -- of DetermineQualification --
      
    AnalyzeOrigin: PROCEDURE [index: FieldIndex] =
      BEGIN
      fieldBodyStartIndex: CharIndex = getCharIndex;
      
      ProcessName: PROCEDURE [
	simpleName, registry, arpaHost: STRING, ignored: MailParse.NameInfo]
	RETURNS [accept: BOOLEAN] =
	BEGIN
	IF ~(originIndex = sender OR index = originIndex OR index = reply) THEN
	  BEGIN OPEN String;
	  originIndex _ index;
	  originName.simpleName.length _ originName.registry.length _
	    originName.arpaHost.length _ 0;
	  AppendString[originName.simpleName, simpleName];
	  AppendString[originName.registry, registry];
	  AppendString[originName.arpaHost, arpaHost];
	  originQual _ DetermineQualification[originName];
	  originQual _ AdjustToReplyerContext[originName, originQual];
	  END;
	IF index < answerTarget AND
	  ~(originQual = arpaQualified AND index = sender) THEN
	  BEGIN
	  answerTarget _ index;
	  answerTargetBodyCharIndex _ fieldBodyStartIndex;
	  END;
	RETURN[FALSE]
	END; -- of ProcessName --
	
      MailParse.ParseNameList[pH, ProcessName];
      END; -- of AnalyzeOrigin --
      
    FirstPass: PROCEDURE [index: FieldIndex] =
      BEGIN
      discard: STRING _ [0];
      SELECT index FROM
	id => {idIndex _ getCharIndex; MailParse.GetFieldBody[pH, discard]};
	IN [reply..from] => AnalyzeOrigin[index];
	IN [to..bcc] => FillNameField[firstPass: TRUE];
	date => {dateIndex _ getCharIndex; MailParse.GetFieldBody[pH, discard]};
	subject => {subjectIndex _ getCharIndex; MailParse.GetFieldBody[pH, discard]};
	ENDCASE => MailParse.GetFieldBody[pH, discard];
      RETURN
      END; -- of FirstPass --
      
    AppendMessageID: PROCEDURE =
      BEGIN
      StuffChar[',];
      StuffChar[Ascii.SP];
      FillField[];
      END; -- of AppendMessageID --
      
    LocalArpaSite: PROCEDURE [host: STRING] RETURNS [BOOLEAN] =
      BEGIN
      FOR i: CARDINAL IN [0..LENGTH[arpaGatewayHostNames]) DO
	IF String.EquivalentString[host, arpaGatewayHostNames[i]] THEN RETURN[TRUE];
	ENDLOOP;
      RETURN[FALSE]
      END; -- of LocalArpaSite --
      
    AdjustToSenderContext: PROCEDURE [name: Name] RETURNS [qual: Qualification] =
      BEGIN
      DO
	-- loops only if name has local Arpa qualification and originator is local as well.
	SELECT qual _ DetermineQualification[name] FROM
	  unqualified => EXIT;
	  dotQualified =>
	    BEGIN
	    senderRegistry: STRING;
	    SELECT originQual FROM
	      unqualified => senderRegistry _ userRegistry;
	      dotQualified => senderRegistry _ originName.registry;
	      arpaQualified => EXIT;
	      ENDCASE;
	    IF String.EquivalentString[name.registry, senderRegistry] THEN
	      BEGIN name.registry.length _ 0; qual _ unqualified; END;
	    EXIT
	    END;
	  arpaQualified =>
	    BEGIN
	    nameIsLocalArpa: BOOLEAN = LocalArpaSite[name.arpaHost];
	    IF nameIsLocalArpa AND name.registry.length = 0 AND
	      ~replyerRegIsDefault THEN
	      String.AppendString[name.registry, defaultRegistry];
	    IF originQual ~= arpaQualified THEN
	      IF nameIsLocalArpa THEN name.arpaHost.length _ 0 -- and LOOP
	      ELSE EXIT
	    ELSE
	      BEGIN
	      IF String.EquivalentString[name.arpaHost, originName.arpaHost] THEN {
		name.arpaHost.length _ 0; qual _ DetermineQualification[name]};
	      EXIT
	      END;
	    END;
	  ENDCASE;
	ENDLOOP;
      END; -- of AdjustToSenderContext --
      
    AdjustToReplyerContext: PROCEDURE [name: Name, qual: Qualification]
      RETURNS [newQual: Qualification] =
      BEGIN
      SELECT newQual _ qual FROM
	unqualified =>
	  SELECT newQual _ originQual FROM
	    dotQualified =>
	      SELECT name.simpleName[0] FROM
		'@, '" => NULL;
		ENDCASE => String.AppendString[name.registry, originName.registry];
	    arpaQualified => GO TO AddOriginHost;
	    ENDCASE;
	dotQualified =>
	  SELECT originQual FROM
	    unqualified, dotQualified => GO TO CheckEqualNA;
	    arpaQualified => BEGIN newQual _ originQual; GO TO AddOriginHost END;
	    ENDCASE;
	arpaQualified =>
	  IF LocalArpaSite[name.arpaHost] THEN
	    BEGIN
	    name.arpaHost.length _ 0;
	    newQual _ qual _ DetermineQualification[name];
	    IF qual = dotQualified THEN GO TO CheckEqualNA;
	    END;
	ENDCASE;
      EXITS
	AddOriginHost => String.AppendString[name.arpaHost, originName.arpaHost];
	CheckEqualNA =>
	  IF String.EquivalentString[name.registry, userRegistry] THEN
	    BEGIN newQual _ unqualified; name.registry.length _ 0; END;
      END; -- of AdjustToReplyerContext --
      
    FillField: PROCEDURE =
      BEGIN
      field: STRING = [124];
      MailParse.GetFieldBody[pH, field];
      IF field.length > field.maxlength - 4 THEN
	BEGIN
	field.length _ field.maxlength - 4;
	String.AppendString[field, " ..."L];
	END;
      AppendStringToBuffer[@buffer, field];
      END; -- of FillField --
      
    AddedToDuplicateList: PROCEDURE [name: Name, firstPass: BOOLEAN]
      RETURNS [added: BOOLEAN] =
      BEGIN
      item: DuplicateNameHandle;
      size: CARDINAL =
	name.simpleName.length +
	  (IF name.registry.length ~= 0 THEN name.registry.length + 1 ELSE 0) +
	  (IF name.arpaHost.length ~= 0 THEN name.arpaHost.length + 1 ELSE 0);
      s: STRING _ Storage.String[size];
      String.AppendString[s, name.simpleName];
      IF name.registry.length ~= 0 THEN
	{String.AppendChar[s, '.]; String.AppendString[s, name.registry]};
      IF name.arpaHost.length ~= 0 THEN
	{String.AppendChar[s, '@]; String.AppendString[s, name.arpaHost]};
      FOR item _ DuplicateHead, item.next UNTIL item = NIL DO
	IF String.EquivalentString[item.name, s] THEN
	  BEGIN
	  Storage.FreeString[s];
	  IF firstPass THEN RETURN[FALSE];
	  added _ ~item.seenOnSecondPass;
	  item.seenOnSecondPass _ TRUE;
	  RETURN
	  END;
	ENDLOOP;
      item _ Storage.Node[SIZE[DuplicateName]];
      item.name _ s;
      item.seenOnSecondPass _ FALSE;
      item.next _ DuplicateHead;
      DuplicateHead _ item;
      RETURN[TRUE]
      END; -- of AddedToDuplicateList --
      
    ReleaseDuplicateList: PROCEDURE =
      BEGIN
      item: DuplicateNameHandle;
      UNTIL DuplicateHead = NIL DO
	item _ DuplicateHead.next;
	Storage.FreeString[DuplicateHead.name];
	Storage.Free[DuplicateHead];
	DuplicateHead _ item;
	ENDLOOP;
      END; -- of ReleaseDuplicateList --
      
    ProcessAnswerTarget: PROCEDURE =
      BEGIN
      
      ProcessName: PROCEDURE [
	simpleName, registry, arpaHost: STRING, ignored: MailParse.NameInfo]
	RETURNS [accept: BOOLEAN] =
	BEGIN
	name: NameRecord _ [simpleName, registry, arpaHost];
	qual: Qualification _ AdjustToSenderContext[@name];
	[] _ AddedToDuplicateList[@name, FALSE];
	[] _ AdjustToReplyerContext[@name, qual];
	RETURN[TRUE];
	END; -- of ProcessName --
	
      getCharIndex _ answerTargetBodyCharIndex;
      InitParse[];
      MailParse.ParseNameList[pH, ProcessName, StuffChar, TRUE];
      FinParse[];
      END; -- of ProcessAnswerTarget --
      
    AnalyzeAnswerTarget: PROCEDURE =
      BEGIN
      
      ProcessName: PROCEDURE [
	simpleName, registry, arpaHost: STRING, ignored: MailParse.NameInfo]
	RETURNS [accept: BOOLEAN] =
	BEGIN
	name: NameRecord _ [simpleName, registry, arpaHost];
	qual: Qualification _ AdjustToSenderContext[@name];
        targetEqualsOrigin _ targetEqualsOrigin AND
	  String.EquivalentString[simpleName, originName.simpleName] AND
	  String.EquivalentString[registry, originName.registry] AND
	  String.EquivalentString[arpaHost, originName.arpaHost];
	IF ~AddedToDuplicateList[@name, TRUE] THEN ccCount _ ccCount - 1;
	RETURN[FALSE];
	END; -- of ProcessName --
	
      IF answerTargetBodyCharIndex = 0 THEN
	ERROR MailParse.ParseError[badFieldName];
      getCharIndex _ answerTargetBodyCharIndex;
      InitParse[];
      MailParse.ParseNameList[pH, ProcessName, !
	MailParse.ParseError => answerError _ TRUE];
      FinParse[];
      END; -- of AnalyzeAnswerTarget --
      
    FillNameField: PROCEDURE [firstPass: BOOLEAN] =
      BEGIN
      firstOutput: BOOLEAN _ TRUE;
      
      ProcessName: PROCEDURE [
	simpleName, registry, arpaHost: STRING, nameInfo: MailParse.NameInfo]
	RETURNS [accept: BOOLEAN] =
	BEGIN
	name: NameRecord _ [simpleName, registry, arpaHost];
	qual: Qualification _ AdjustToSenderContext[@name];
	new: BOOLEAN _ AddedToDuplicateList[@name, firstPass];
	IF nameInfo.nesting = none AND ~new THEN RETURN[FALSE];
	[] _ AdjustToReplyerContext[@name, qual];
	IF firstPass THEN
	  BEGIN
	  ccCount _ ccCount + 1;
	  IF ~replyerCCed AND String.EquivalentString[simpleName, userName] AND
	    registry.length = 0 AND arpaHost.length = 0 THEN replyerCCed _ TRUE;
	  RETURN[FALSE]
	  END;
	IF firstOutput THEN
	  BEGIN
	  firstOutput _ FALSE;
	  IF namesOutput THEN {StuffChar[',]; StuffChar[Ascii.SP]}
	  END;
	RETURN[namesOutput _ TRUE]
	END; -- of ProcessName --
	
      MailParse.ParseNameList[pH, ProcessName, StuffChar, TRUE];
      END; -- of FillNameField --
      
    SecondPass: PROCEDURE [index: FieldIndex] =
      BEGIN
      discard: STRING = [0];
      SELECT index FROM
	IN [to..bcc] => FillNameField[firstPass: FALSE];
	ENDCASE => MailParse.GetFieldBody[pH, discard];
      END; -- of SecondPass --
      
    PutBuffer: PROCEDURE =
      BEGIN
      AppendToBuffer[@buffer, Ascii.CR];
      putBlock[[@buffer.text, buffer.length]];
      buffer.length _ 0;
      END; -- of PutBuffer --
      
  -- main body of AnswerCommand
  
    answerError _ FALSE;
    buffer _ NewBuffer[1];
    
    BEGIN
    
    -- find out who it's from and where the interesting indices are
    ProcessFields[FirstPass ! MailParse.ParseError => GO TO BadMessage];
    AnalyzeAnswerTarget[ ! MailParse.ParseError => GO TO BadMessage];
    
    -- make Subject field
    AppendStringToBuffer[@buffer, "Subject: Re: "L];
    IF subjectIndex # nullIndex THEN {
      getCharIndex _ subjectIndex; InitParse[]; FillField[]; FinParse[]};
    reStart _ 13;
    WHILE (buffer.length > reStart + 2) AND
      (String.LowerCase[buffer[reStart]] = 'r) AND
      (String.LowerCase[buffer[reStart+1]] = 'e) AND
      (buffer[reStart+2] = ':) DO
      DeleteRangeInBuffer[buffer, reStart, reStart + 3];
      WHILE buffer.length > reStart AND buffer[reStart] = Ascii.SP DO
	DeleteRangeInBuffer[buffer, reStart, reStart + 1]; ENDLOOP;
      ENDLOOP;
    PutBuffer[];
      
    -- make In-reply-to field
    AppendStringToBuffer[@buffer, "In-reply-to: "L];
    IF (IF answerTarget = reply THEN targetEqualsOrigin
       ELSE (ccCount = 0 OR (replyerCCed AND ccCount = 1))) THEN
      AppendStringToBuffer[@buffer, "Your"L]
    ELSE
      BEGIN
      AppendStringToBuffer[@buffer, originSN];
      IF originReg.length ~= 0 THEN
	BEGIN
	AppendToBuffer[@buffer, '.];
	AppendStringToBuffer[@buffer, originReg];
	END;
      AppendToBuffer[@buffer, ''];
      IF originReg.length ~= 0 OR String.LowerCase[originSN[originSN.length - 1]] ~= 's
	THEN AppendToBuffer[@buffer, 's];
      END;
    AppendStringToBuffer[@buffer, " message of "L];
    InitParse[];
    IF dateIndex # nullIndex THEN {getCharIndex _ dateIndex; FillField[]};
    IF idIndex # nullIndex THEN {getCharIndex _ idIndex; AppendMessageID[]};
    FinParse[];
    PutBuffer[];
    
    -- fill in target (To:) field of answer form
    AppendStringToBuffer[@buffer, "To: "L];
    ProcessAnswerTarget[];
    PutBuffer[];
    
    -- fill in cc: field
    AppendStringToBuffer[@buffer, IF cForCopies THEN "c:  "L ELSE "cc: "L];
    IF answerTarget = reply THEN AppendStringToBuffer[@buffer, userName]
    ELSE ProcessFields[SecondPass ! MailParse.ParseError => GO TO BadMessage];
    PutBuffer[];
    
    -- empty line at end of header
    PutBuffer[];
    
    EXITS BadMessage => {IF havePH THEN FinParse[]; answerError _ TRUE};
    END;
    
    freePages[buffer];
    ReleaseDuplicateList[];
    
    RETURN[answerError]
    END; -- of MakeHeader --
    
    
  END.  -- AnswerImpl --